Theory Utils

theory Utils
  imports "ZF-Constructible.Formula"
begin

ML_file ‹utils.ML›

end

File ‹utils.ML›

signature UTILS =
 sig
    val binop : term -> term -> term -> term
    val add_: term -> term -> term
    val app_: term -> term -> term
    val concat_: term -> term -> term
    val dest_apply: term -> term * term
    val dest_iff_lhs: term -> term
    val dest_iff_rhs: term -> term
    val dest_iff_tms: term -> term * term
    val dest_lhs_def: term -> term
    val dest_rhs_def: term -> term
    val dest_satisfies_tms: term -> term * term
    val dest_satisfies_frm: term -> term
    val dest_eq_tms: term -> term * term
    val dest_sats_frm: term -> (term * term) * term
    val dest_trueprop: term -> term
    val eq_: term -> term -> term
    val fix_vars: thm -> string list -> Proof.context -> thm
    val formula_: term
    val freeName: term -> string
    val inList: ''a -> ''a list -> bool
    val isFree: term -> bool
    val length_: term -> term
    val list_: term -> term
    val lt_: term -> term -> term
    val mem_: term -> term -> term
    val mk_FinSet: term list -> term
    val mk_Pair: term -> term -> term
    val mk_ZFlist: ('a -> term) -> 'a list -> term
    val mk_ZFnat: int -> term
    val nat_: term
    val nth_: term -> term -> term
    val subset_: term -> term -> term
    val thm_concl_tm :  Proof.context -> xstring -> 
        ((indexname * typ) * cterm) list * term * Proof.context
    val to_ML_list: term -> term list
    val tp: term -> term
  end

structure Utils : UTILS =
struct 
(* Smart constructors for ZF-terms *)

fun inList a = exists (fn b => a = b)

fun binop h t u = h $ t $ u
val mk_Pair  = binop @{const Pair}

fun mk_FinSet nil = @{const zero}
  | mk_FinSet (e :: es) = @{const cons} $ e $ mk_FinSet es

fun mk_ZFnat 0 = @{const zero}
  | mk_ZFnat n = @{const succ} $ mk_ZFnat (n-1)

fun mk_ZFlist _ nil = @{const "Nil"}
  | mk_ZFlist f (t :: ts) = @{const "Cons"} $ f t $ mk_ZFlist f ts

fun to_ML_list (@{const Nil}) = nil
  | to_ML_list (@{const Cons} $ t $ ts) = t :: to_ML_list ts
|   to_ML_list _ = nil

fun isFree (Free (_,_)) = true
  | isFree _ = false

fun freeName (Free (n,_)) = n
  | freeName _ = error "Not a free variable"

val app_ = binop @{const apply}

fun tp x = @{const Trueprop} $ x
fun length_ env = @{const length} $ env
val nth_ = binop @{const nth}
val add_ = binop @{const add}
val mem_ = binop @{const mem}
val subset_ = binop @{const Subset}
val lt_ = binop @{const lt}
val concat_ = binop @{const app}
val eq_ = binop @{const IFOL.eq(i)}

(* Abbreviation for sets *)
fun list_ set = @{const list} $ set
val nat_ = @{const nat}
val formula_ = @{const formula}

(** Destructors of terms **)
fun dest_eq_tms (Const (@{const_name IFOL.eq},_) $ t $ u) = (t, u)
  | dest_eq_tms t = raise TERM ("dest_eq_tms", [t])

fun dest_lhs_def (Const (@{const_name Pure.eq},_) $ x $ _) = x
  | dest_lhs_def t = raise TERM ("dest_lhs_def", [t])

fun dest_rhs_def (Const (@{const_name Pure.eq},_) $ _ $ y) = y
  | dest_rhs_def t = raise TERM ("dest_rhs_def", [t])


fun dest_apply (@{const apply} $ t $ u) = (t,u)
  | dest_apply t = raise TERM ("dest_applies_op", [t])

fun dest_satisfies_tms (@{const Formula.satisfies} $ A $ f) = (A,f)
  | dest_satisfies_tms t = raise TERM ("dest_satisfies_tms", [t]);

val dest_satisfies_frm = #2 o dest_satisfies_tms

fun dest_sats_frm t = t |> dest_eq_tms |> #1 |> dest_apply |>> dest_satisfies_tms ;

fun dest_trueprop (@{const IFOL.Trueprop} $ t) = t
  | dest_trueprop t = t

fun dest_iff_tms (@{const IFOL.iff} $ t $ u) = (t, u)
  | dest_iff_tms t = raise TERM ("dest_iff_tms", [t])

val dest_iff_lhs = #1 o dest_iff_tms
val dest_iff_rhs = #2 o dest_iff_tms

fun thm_concl_tm ctxt thm_ref =
  let val (((_,vars),thm_tms),ctxt1) = Variable.import true [Proof_Context.get_thm ctxt thm_ref] ctxt
  in (vars, thm_tms |> hd |> Thm.concl_of, ctxt1)
end

fun fix_vars thm vars ctxt = let
  val (_, ctxt1) = Variable.add_fixes vars ctxt
  in singleton (Proof_Context.export ctxt1 ctxt) thm
end

end ;

Theory Forcing_Notions

section‹Forcing notions›
text‹This theory defines a locale for forcing notions, that is,
 preorders with a distinguished maximum element.›

theory Forcing_Notions
  imports "ZF-Constructible.Relative"
begin

subsection‹Basic concepts›
text‹We say that two elements $p,q$ are
  ‹compatible› if they have a lower bound in $P$›
definition compat_in :: "iiiio" where
  "compat_in(A,r,p,q)  dA . d,pr  d,qr"

definition
  is_compat_in :: "[io,i,i,i,i]  o" where
  "is_compat_in(M,A,r,p,q)  d[M]. dA  (dp[M]. pair(M,d,p,dp)  dpr  
                                   (dq[M]. pair(M,d,q,dq)  dqr))"

lemma compat_inI : 
  " dA ; d,pr ; d,gr   compat_in(A,r,p,g)"
  by (auto simp add: compat_in_def)

lemma refl_compat:
  " refl(A,r) ; p,q  r | p=q | q,p  r ; pA ; qA  compat_in(A,r,p,q)"
  by (auto simp add: refl_def compat_inI)

lemma  chain_compat:
  "refl(A,r)  linear(A,r)   (pA.qA. compat_in(A,r,p,q))"
  by (simp add: refl_compat linear_def)

lemma subset_fun_image: "f:NP  f``NP"
  by (auto simp add: image_fun apply_funtype)

lemma refl_monot_domain: "refl(B,r)  AB  refl(A,r)"  
  unfolding refl_def by blast

definition
  antichain :: "iiio" where
  "antichain(P,leq,A)  AP  (pA.qA.(¬ compat_in(P,leq,p,q)))"

definition 
  ccc :: "i  i  o" where
  "ccc(P,leq)  A. antichain(P,leq,A)  |A|  nat"

locale forcing_notion =
  fixes P leq one
  assumes one_in_P:         "one  P"
    and leq_preord:       "preorder_on(P,leq)"
    and one_max:          "pP. p,oneleq"
begin

abbreviation Leq :: "[i, i]  o"  (infixl "" 50)
  where "x  y  x,yleq"

lemma refl_leq:
  "rP  rr"
  using leq_preord unfolding preorder_on_def refl_def by simp

text‹A set $D$ is ‹dense› if every element $p\in P$ has a lower 
bound in $D$.›
definition 
  dense :: "io" where
  "dense(D)  pP. dD . dp"

text‹There is also a weaker definition which asks for 
a lower bound in $D$ only for the elements below some fixed 
element $q$.›
definition 
  dense_below :: "iio" where
  "dense_below(D,q)  pP. pq  (dD. dP  dp)"

lemma P_dense: "dense(P)"
  by (insert leq_preord, auto simp add: preorder_on_def refl_def dense_def)

definition 
  increasing :: "io" where
  "increasing(F)  xF.  p  P . xp  pF"

definition 
  compat :: "iio" where
  "compat(p,q)  compat_in(P,leq,p,q)"

lemma leq_transD:  "ab  bc  a  P b  P c  P ac"
  using leq_preord trans_onD unfolding preorder_on_def by blast

lemma leq_transD':  "AP  ab  bc  a  A  b  P c  P ac"
  using leq_preord trans_onD subsetD unfolding preorder_on_def by blast


lemma leq_reflI: "pP  pp"
  using leq_preord unfolding preorder_on_def refl_def by blast

lemma compatD[dest!]: "compat(p,q)  dP. dp  dq"
  unfolding compat_def compat_in_def .

abbreviation Incompatible :: "[i, i]  o"  (infixl "" 50)
  where "p  q  ¬ compat(p,q)"

lemma compatI[intro!]: "dP  dp  dq  compat(p,q)"
  unfolding compat_def compat_in_def by blast

lemma denseD [dest]: "dense(D)  pP   dD. d p"
  unfolding dense_def by blast

lemma denseI [intro!]: " p. pP  dD. d p   dense(D)"
  unfolding dense_def by blast

lemma dense_belowD [dest]:
  assumes "dense_below(D,p)" "qP" "qp"
  shows "dD. dP  dq"
  using assms unfolding dense_below_def by simp
    (*obtains d where "d∈D" "d∈P" "d≼q"
  using assms unfolding dense_below_def by blast *)

lemma dense_belowI [intro!]: 
  assumes "q. qP  qp  dD. dP  dq" 
  shows "dense_below(D,p)"
  using assms unfolding dense_below_def by simp

lemma dense_below_cong: "pP  D = D'  dense_below(D,p)  dense_below(D',p)"
  by blast

lemma dense_below_cong': "pP  x. xP  Q(x)  Q'(x)  
           dense_below({qP. Q(q)},p)  dense_below({qP. Q'(q)},p)"
  by blast

lemma dense_below_mono: "pP  D  D'  dense_below(D,p)  dense_below(D',p)"
  by blast

lemma dense_below_under:
  assumes "dense_below(D,p)" "pP" "qP" "qp"
  shows "dense_below(D,q)"
  using assms leq_transD by blast

lemma ideal_dense_below:
  assumes "q. qP  qp  qD"
  shows "dense_below(D,p)"
  using assms leq_reflI by blast

lemma dense_below_dense_below: 
  assumes "dense_below({qP. dense_below(D,q)},p)" "pP" 
  shows "dense_below(D,p)"  
  using assms leq_transD leq_reflI  by blast
    (* Long proof *)
    (*  unfolding dense_below_def
proof (intro ballI impI)
  fix r
  assume "r∈P" ‹r≼p›
  with assms
  obtain q where "q∈P" "q≼r" "dense_below(D,q)"
    using assms by auto
  moreover from this
  obtain d where "d∈P" "d≼q" "d∈D"
    using assms leq_preord unfolding preorder_on_def refl_def by blast
  moreover
  note ‹r∈P›
  ultimately
  show "∃d∈D. d ∈ P ∧ d≼ r"
    using leq_preord trans_onD unfolding preorder_on_def by blast
qed *)

definition
  antichain :: "io" where
  "antichain(A)  AP  (pA.qA.(¬compat(p,q)))"

text‹A filter is an increasing set $G$ with all its elements 
being compatible in $G$.›
definition 
  filter :: "io" where
  "filter(G)  GP  increasing(G)  (pG. qG. compat_in(G,leq,p,q))"

lemma filterD : "filter(G)  x  G  x  P"
  by (auto simp add : subsetD filter_def)

lemma filter_leqD : "filter(G)  x  G  y  P  xy  y  G"
  by (simp add: filter_def increasing_def)

lemma filter_imp_compat: "filter(G)  pG  qG  compat(p,q)"
  unfolding filter_def compat_in_def compat_def by blast

lemma low_bound_filter: ― ‹says the compatibility is attained inside G›
  assumes "filter(G)" and "pG" and "qG"
  shows "rG. rp  rq" 
  using assms 
  unfolding compat_in_def filter_def by blast

text‹We finally introduce the upward closure of a set
and prove that the closure of $A$ is a filter if its elements are
compatible in $A$.›
definition  
  upclosure :: "ii" where
  "upclosure(A)  {pP.aA. ap}"

lemma  upclosureI [intro] : "pP  aA  ap  pupclosure(A)"
  by (simp add:upclosure_def, auto)

lemma  upclosureE [elim] :
  "pupclosure(A)  (x a. xP  aA  ax  R)  R"
  by (auto simp add:upclosure_def)

lemma  upclosureD [dest] :
  "pupclosure(A)  aA.(ap)  pP"
  by (simp add:upclosure_def)

lemma upclosure_increasing :
  assumes "AP"
  shows "increasing(upclosure(A))"
  unfolding increasing_def upclosure_def
  using leq_transD'[OF AP] by auto

lemma  upclosure_in_P: "A  P  upclosure(A)  P"
  using subsetI upclosure_def by simp

lemma  A_sub_upclosure: "A  P  Aupclosure(A)"
  using subsetI leq_preord 
  unfolding upclosure_def preorder_on_def refl_def by auto

lemma  elem_upclosure: "AP  xA   xupclosure(A)"
  by (blast dest:A_sub_upclosure)

lemma  closure_compat_filter:
  assumes "AP" "(pA.qA. compat_in(A,leq,p,q))"
  shows "filter(upclosure(A))"
  unfolding filter_def
proof(auto)
  show "increasing(upclosure(A))"
    using assms upclosure_increasing by simp
next
  let ?UA="upclosure(A)"
  show "compat_in(upclosure(A), leq, p, q)" if "p?UA" "q?UA" for p q
  proof -
    from that
    obtain a b where 1:"aA" "bA" "ap" "bq" "pP" "qP"
      using upclosureD[OF p?UA] upclosureD[OF q?UA] by auto
    with assms(2)
    obtain d where "dA" "da" "db"
      unfolding compat_in_def by auto
    with 1
    have 2:"dp" "dq" "d?UA"
      using A_sub_upclosure[THEN subsetD] AP
        leq_transD'[of A d a] leq_transD'[of A d b] by auto
    then
    show ?thesis unfolding compat_in_def by auto
  qed
qed

lemma  aux_RS1:  "f  N  P  nN  f`n  upclosure(f ``N)"
  using elem_upclosure[OF subset_fun_image] image_fun
  by (simp, blast)

lemma decr_succ_decr: 
  assumes "f  nat  P" "preorder_on(P,leq)"
    "nnat.  f ` succ(n), f ` n  leq"
    "mnat"
  shows "nnat  nm  f ` m, f ` n  leq"
  using m_
proof(induct m)
  case 0
  then show ?case using assms leq_reflI by simp
next
  case (succ x)
  then
  have 1:"f`succ(x)  f`x" "f`nP" "f`xP" "f`succ(x)P"
    using assms by simp_all
  consider (lt) "n<succ(x)" | (eq) "n=succ(x)"
    using succ le_succ_iff by auto
  then 
  show ?case 
  proof(cases)
    case lt
    with 1 show ?thesis using leI succ leq_transD by auto
  next
    case eq
    with 1 show ?thesis using leq_reflI by simp
  qed
qed

lemma decr_seq_linear: 
  assumes "refl(P,leq)" "f  nat  P"
    "nnat.  f ` succ(n), f ` n  leq"
    "trans[P](leq)"
  shows "linear(f `` nat, leq)"
proof -
  have "preorder_on(P,leq)" 
    unfolding preorder_on_def using assms by simp
  {
    fix n m
    assume "nnat" "mnat"
    then
    have "f`m  f`n  f`n  f`m"
    proof(cases "mn")
      case True
      with n_ m_
      show ?thesis 
        using decr_succ_decr[of f n m] assms leI ‹preorder_on(P,leq) by simp
    next
      case False
      with n_ m_
      show ?thesis 
        using decr_succ_decr[of f m n] assms leI not_le_iff_lt ‹preorder_on(P,leq) by simp
    qed
  }
  then
  show ?thesis
    unfolding linear_def using ball_image_simp assms by auto
qed

end (* forcing_notion *)

subsection‹Towards Rasiowa-Sikorski Lemma (RSL)›
locale countable_generic = forcing_notion +
  fixes 𝒟
  assumes countable_subs_of_P:  "𝒟  natPow(P)"
    and     seq_of_denses:        "n  nat. dense(𝒟`n)"

begin

definition
  D_generic :: "io" where
  "D_generic(G)  filter(G)  (nnat.(𝒟`n)G0)"

text‹The next lemma identifies a sufficient condition for obtaining
RSL.›
lemma RS_sequence_imp_rasiowa_sikorski:
  assumes 
    "pP" "f : natP" "f ` 0 = p"
    "n. nnat  f ` succ(n) f ` n  f ` succ(n)  𝒟 ` n" 
  shows
    "G. pG  D_generic(G)"
proof -
  note assms
  moreover from this 
  have "f``nat   P"
    by (simp add:subset_fun_image)
  moreover from calculation
  have "refl(f``nat, leq)  trans[P](leq)"
    using leq_preord unfolding preorder_on_def by (blast intro:refl_monot_domain)
  moreover from calculation 
  have "nnat.  f ` succ(n) f ` n" by (simp)
  moreover from calculation
  have "linear(f``nat, leq)"
    using leq_preord and decr_seq_linear unfolding preorder_on_def by (blast)
  moreover from calculation
  have "(pf``nat.qf``nat. compat_in(f``nat,leq,p,q))"             
    using chain_compat by (auto)
  ultimately  
  have "filter(upclosure(f``nat))" (is "filter(?G)")
    using closure_compat_filter by simp
  moreover
  have "nnat. 𝒟 ` n  ?G  0"
  proof
    fix n
    assume "nnat"
    with assms 
    have "f`succ(n)  ?G  f`succ(n)  𝒟 ` n"
      using aux_RS1 by simp
    then 
    show "𝒟 ` n  ?G  0"  by blast
  qed
  moreover from assms 
  have "p  ?G"
    using aux_RS1 by auto
  ultimately 
  show ?thesis unfolding D_generic_def by auto
qed

end (* countable_generic *)

text‹Now, the following recursive definition will fulfill the 
requirements of lemma termRS_sequence_imp_rasiowa_sikorski

consts RS_seq :: "[i,i,i,i,i,i]  i"
primrec
  "RS_seq(0,P,leq,p,enum,𝒟) = p"
  "RS_seq(succ(n),P,leq,p,enum,𝒟) = 
    enum`(μ m. enum`m, RS_seq(n,P,leq,p,enum,𝒟)  leq  enum`m  𝒟 ` n)"

context countable_generic
begin

lemma preimage_rangeD:
  assumes "fPi(A,B)" "b  range(f)" 
  shows "aA. f`a = b"
  using assms apply_equality[OF _ assms(1), of _ b] domain_type[OF _ assms(1)] by auto

lemma countable_RS_sequence_aux:
  fixes p enum
  defines "f(n)  RS_seq(n,P,leq,p,enum,𝒟)"
    and   "Q(q,k,m)  enum`m q  enum`m  𝒟 ` k"
  assumes "nnat" "pP" "P  range(enum)" "enum:natM"
    "x k. xP  knat   qP. q x  q  𝒟 ` k" 
  shows 
    "f(succ(n))  P  f(succ(n)) f(n)  f(succ(n))  𝒟 ` n"
  using nnat›
proof (induct)
  case 0
  from assms 
  obtain q where "qP" "q p" "q  𝒟 ` 0" by blast
  moreover from this and P  range(enum)
  obtain m where "mnat" "enum`m = q" 
    using preimage_rangeD[OF enum:natM] by blast
  moreover 
  have "𝒟`0  P"
    using apply_funtype[OF countable_subs_of_P] by simp
  moreover note pP
  ultimately
  show ?case 
    using LeastI[of "Q(p,0)" m] unfolding Q_def f_def by auto
next
  case (succ n)
  with assms 
  obtain q where "qP" "q f(succ(n))" "q  𝒟 ` succ(n)" by blast
  moreover from this and P  range(enum)
  obtain m where "mnat" "enum`m f(succ(n))" "enum`m  𝒟 ` succ(n)"
    using preimage_rangeD[OF enum:natM] by blast
  moreover note succ
  moreover from calculation
  have "𝒟`succ(n)  P" 
    using apply_funtype[OF countable_subs_of_P] by auto
  ultimately
  show ?case
    using LeastI[of "Q(f(succ(n)),succ(n))" m] unfolding Q_def f_def by auto
qed

lemma countable_RS_sequence:
  fixes p enum
  defines "f  λnnat. RS_seq(n,P,leq,p,enum,𝒟)"
    and   "Q(q,k,m)  enum`m q  enum`m  𝒟 ` k"
  assumes "nnat" "pP" "P  range(enum)" "enum:natM"
  shows 
    "f`0 = p" "f`succ(n) f`n  f`succ(n)  𝒟 ` n" "f`succ(n)  P"
proof -
  from assms
  show "f`0 = p" by simp
  {
    fix x k
    assume "xP" "knat"
    then
    have "qP. q x  q  𝒟 ` k"
      using seq_of_denses apply_funtype[OF countable_subs_of_P] 
      unfolding dense_def by blast
  }
  with assms
  show "f`succ(n) f`n  f`succ(n)  𝒟 ` n" "f`succ(n)P"
    unfolding f_def using countable_RS_sequence_aux by simp_all
qed

lemma RS_seq_type: 
  assumes "n  nat" "pP" "P  range(enum)" "enum:natM"
  shows "RS_seq(n,P,leq,p,enum,𝒟)  P"
  using assms countable_RS_sequence(1,3)  
  by (induct;simp) 

lemma RS_seq_funtype:
  assumes "pP" "P  range(enum)" "enum:natM"
  shows "(λnnat. RS_seq(n,P,leq,p,enum,𝒟)): nat  P"
  using assms lam_type RS_seq_type by auto

lemmas countable_rasiowa_sikorski = 
  RS_sequence_imp_rasiowa_sikorski[OF _ RS_seq_funtype countable_RS_sequence(1,2)]
end (* countable_generic *)

end

Theory Pointed_DC

section‹A pointed version of DC›
theory Pointed_DC imports ZF.AC

begin
txt‹This proof of DC is from Moschovakis "Notes on Set Theory"›

consts dc_witness :: "i  i  i  i  i  i"
primrec
  wit0   : "dc_witness(0,A,a,s,R) = a"
  witrec :"dc_witness(succ(n),A,a,s,R) = s`{xA. dc_witness(n,A,a,s,R),xR }"

lemma witness_into_A [TC]:
  assumes "aA"
    "(X . X0  XA  s`XX)"
    "yA. {xA. y,xR }  0" "nnat"
  shows "dc_witness(n, A, a, s, R)A"
  using nnat›
proof(induct n)
  case 0
  then show ?case using aA by simp
next
  case (succ x)
  then
  show ?case using assms by auto
qed

lemma witness_related :
  assumes "aA"
    "(X . X0  XA  s`XX)"
    "yA. {xA. y,xR }  0" "nnat"
  shows "dc_witness(n, A, a, s, R),dc_witness(succ(n), A, a, s, R)R"
proof -
  from assms
  have "dc_witness(n, A, a, s, R)A" (is "?x  A")
    using witness_into_A[of _ _ s R n] by simp
  with assms
  show ?thesis by auto
qed

lemma witness_funtype:
  assumes "aA"
    "(X . X0  XA  s`XX)"
    "yA. {xA. y,xR }  0"
  shows "(λnnat. dc_witness(n, A, a, s, R))  nat  A" (is "?f  _  _")
proof -
  have "?f  nat  {dc_witness(n, A, a, s, R). nnat}" (is "_  _  ?B")
    using lam_funtype assms by simp
  then
  have "?B  A"
    using witness_into_A assms by auto
  with ?f  _
  show ?thesis
    using fun_weaken_type
    by simp
qed

lemma witness_to_fun:   assumes "aA"
  "(X . X0  XA  s`XX)"
  "yA. {xA. y,xR }  0"
shows "f  natA. nnat. f`n =dc_witness(n,A,a,s,R)"
  using assms bexI[of _ "λnnat. dc_witness(n,A,a,s,R)"] witness_funtype
  by simp

theorem pointed_DC  :
  assumes "(xA. yA. x,y R)"
  shows "aA. (f  natA. f`0 = a  (n  nat. f`n,f`succ(n)R))"
proof -
  have 0:"yA. {x  A . y, x  R}  0"
    using assms by auto
  from AC_func_Pow[of A]
  obtain g
    where 1: "g  Pow(A) - {0}  A"
      "X. X  0  X  A  g ` X  X"
    by auto
  let ?f ="λa.λnnat. dc_witness(n,A,a,g,R)"
  {
    fix a
    assume "aA"
    from aA
    have f0: "?f(a)`0 = a" by simp
    with aA
    have "?f(a) ` n, ?f(a) ` succ(n)  R" if "nnat" for n
      using witness_related[OF aA 1(2) 0] beta that by simp
    then
    have "fnat  A. f ` 0 = a  (nnat. f ` n, f ` succ(n)  R)" (is "x_ .?P(x)")
      using f0 witness_funtype 0 1 a_ by blast
  }
  then show ?thesis by auto
qed

lemma aux_DC_on_AxNat2 : "xA×nat. yA. x,y,succ(snd(x))  R 
                  xA×nat. yA×nat. x,y  {a,bR. snd(b) = succ(snd(a))}"
  by (rule ballI, erule_tac x="x" in ballE, simp_all)

lemma infer_snd : "c A×B  snd(c) = k  c=fst(c),k"
  by auto

corollary DC_on_A_x_nat :
  assumes "(xA×nat. yA. x,y,succ(snd(x))  R)" "aA"
  shows "f  natA. f`0 = a  (n  nat. f`n,n,f`succ(n),succ(n)R)" (is "x_.?P(x)")
proof -
  let ?R'="{a,bR. snd(b) = succ(snd(a))}"
  from assms(1)
  have "xA×nat. yA×nat. x,y  ?R'"
    using aux_DC_on_AxNat2 by simp
  with a_
  obtain f where
    F:"fnatA×nat" "f ` 0 = a,0"  "nnat. f ` n, f ` succ(n)  ?R'"
    using pointed_DC[of "A×nat" ?R'] by blast
  let ?f="λxnat. fst(f`x)"
  from F
  have "?fnatA" "?f ` 0 = a" by auto
  have 1:"n nat  f`n= ?f`n, n" for n
  proof(induct n set:nat)
    case 0
    then show ?case using F by simp
  next
    case (succ x)
    then
    have "f`x, f`succ(x)  ?R'" "f`x  A×nat" "f`succ(x)A×nat"
      using F by simp_all
    then
    have "snd(f`succ(x)) = succ(snd(f`x))" by simp
    with succ f`x_
    show ?case using infer_snd[OF f`succ(_)_] by auto
  qed
  have "?f`n,n,?f`succ(n),succ(n)  R" if "nnat" for n
    using that 1[of "succ(n)"] 1[OF n_] F(3) by simp
  with f`0=a,0
  show ?thesis using rev_bexI[OF ?f_] by simp
qed

lemma aux_sequence_DC :
  assumes "xA. nnat. yA. x,y  S`n"
    "R={x,n,y,m  (A×nat)×(A×nat). x,yS`m }"
  shows " xA×nat . yA. x,y,succ(snd(x))  R"
  using assms Pair_fst_snd_eq by auto

lemma aux_sequence_DC2 : "xA. nnat. yA. x,y  S`n 
        xA×nat. yA. x,y,succ(snd(x))  {x,n,y,m(A×nat)×(A×nat). x,yS`m }"
  by auto

lemma sequence_DC:
  assumes "xA. nnat. yA. x,y  S`n"
  shows "aA. (f  natA. f`0 = a  (n  nat. f`n,f`succ(n)S`succ(n)))"
  by (rule ballI,insert assms,drule aux_sequence_DC2, drule DC_on_A_x_nat, auto)

end

Theory Rasiowa_Sikorski

section‹The general Rasiowa-Sikorski lemma›
theory Rasiowa_Sikorski imports Forcing_Notions Pointed_DC begin

context countable_generic
begin

lemma RS_relation:
  assumes "pP" "nnat"
  shows "yP. p,y  (λmnat. {x,yP×P. yx  y𝒟`(pred(m))})`n"
proof -
  from seq_of_denses nnat›
  have "dense(𝒟 ` pred(n))" by simp
  with pP
  have "d𝒟 ` Arith.pred(n). d p"
    unfolding dense_def by simp
  then obtain d where 3: "d  𝒟 ` Arith.pred(n)  d p"
    by blast
  from countable_subs_of_P nnat›
  have "𝒟 ` Arith.pred(n)  Pow(P)"
    by (blast dest:apply_funtype intro:pred_type)
  then 
  have "𝒟 ` Arith.pred(n)  P" 
    by (rule PowD)
  with 3
  have "d  P  d p  d  𝒟 ` Arith.pred(n)"
    by auto
  with pP nnat› 
  show ?thesis by auto
qed

lemma DC_imp_RS_sequence:
  assumes "pP"
  shows "f. f: natP  f ` 0 = p  
     (nnat. f ` succ(n) f ` n  f ` succ(n)  𝒟 ` n)"
proof -
  let ?S="(λmnat. {x,yP×P. yx  y𝒟`(pred(m))})"
  have "xP. nnat. yP. x,y  ?S`n" 
    using RS_relation by (auto)
  then
  have "aP. (f  natP. f`0 = a  (n  nat. f`n,f`succ(n)?S`succ(n)))"
    using sequence_DC by (blast)
  with pP
  show ?thesis by auto
qed
  
theorem rasiowa_sikorski:
  "pP  G. pG  D_generic(G)"
  using RS_sequence_imp_rasiowa_sikorski by (auto dest:DC_imp_RS_sequence)

end (* countable_generic *)

end

Theory Nat_Miscellanea

section‹Auxiliary results on arithmetic›
theory Nat_Miscellanea imports ZF begin

text‹Most of these results will get used at some point for the
calculation of arities.›
lemmas nat_succI =  Ord_succ_mem_iff [THEN iffD2,OF nat_into_Ord]

lemma nat_succD : "m  nat   succ(n)  succ(m)  n  m"
  by (drule_tac j="succ(m)" in ltI,auto elim:ltD)

lemmas zero_in =  ltD [OF nat_0_le]

lemma in_n_in_nat :  "m  nat  n  m  n  nat"
  by(drule ltI[of "n"],auto simp add: lt_nat_in_nat)

lemma in_succ_in_nat : "m  nat  n  succ(m)  n  nat"
  by(auto simp add:in_n_in_nat)

lemma ltI_neg : "x  nat  j  x  j  x  j < x"
  by (simp add: le_iff)

lemma succ_pred_eq  :  "m  nat  m  0   succ(pred(m)) = m"
  by (auto elim: natE)

lemma succ_ltI : "succ(j) < n  j < n"
  by (simp add: succ_leE[OF leI])

lemma succ_In : "n  nat  succ(j)  n  j  n"
  by (rule succ_ltI[THEN ltD], auto intro: ltI)

lemmas succ_leD = succ_leE[OF leI]

lemma succpred_leI : "n  nat   n  succ(pred(n))"
  by (auto elim: natE)

lemma succpred_n0 : "succ(n)  p  p0"
  by (auto)


lemma funcI : "f  A  B  a  A  b= f ` a  a, b  f"
  by(simp_all add: apply_Pair)

lemmas natEin = natE [OF lt_nat_in_nat]

lemma succ_in : "succ(x)  y   x  y"
  by (auto dest:ltD)

lemmas Un_least_lt_iffn =  Un_least_lt_iff [OF nat_into_Ord nat_into_Ord]

lemma pred_le2 : "n nat  m  nat  pred(n)  m  n  succ(m)"
  by(subgoal_tac "nnat",rule_tac n="n" in natE,auto)

lemma pred_le : "n nat  m  nat  n  succ(m)  pred(n)  m"
  by(subgoal_tac "pred(n)nat",rule_tac n="n" in natE,auto)

lemma Un_leD1 : "Ord(i) Ord(j) Ord(k)  i  j  k  i  k"   
  by (rule Un_least_lt_iff[THEN iffD1[THEN conjunct1]],simp_all)

lemma Un_leD2 : "Ord(i) Ord(j) Ord(k)  i  j k  j  k"   
  by (rule Un_least_lt_iff[THEN iffD1[THEN conjunct2]],simp_all)

lemma gt1 : "n  nat  i  n  i  0  i  1  1<i"
  by(rule_tac n="i" in natE,erule in_n_in_nat,auto intro: Ord_0_lt)

lemma pred_mono : "m  nat  n  m  pred(n)  pred(m)"
  by(rule_tac n="n" in natE,auto simp add:le_in_nat,erule_tac n="m" in natE,auto)

lemma succ_mono : "m  nat  n  m  succ(n)  succ(m)"
  by auto

lemma pred2_Un: 
  assumes "j  nat" "m  j" "n  j" 
  shows "pred(pred(m  n))  pred(pred(j))" 
  using assms pred_mono[of "j"] le_in_nat Un_least_lt pred_mono by simp

lemma nat_union_abs1 : 
  " Ord(i) ; Ord(j) ; i  j   i  j = j"
  by (rule Un_absorb1,erule le_imp_subset)

lemma nat_union_abs2 : 
  " Ord(i) ; Ord(j) ; i  j   j  i = j"
  by (rule Un_absorb2,erule le_imp_subset)

lemma nat_un_max : "Ord(i)  Ord(j)  i  j = max(i,j)"
  using max_def nat_union_abs1 not_lt_iff_le leI nat_union_abs2
  by auto

lemma nat_max_ty : "Ord(i) Ord(j)  Ord(max(i,j))"
  unfolding max_def by simp

lemma le_not_lt_nat : "Ord(p)  Ord(q)  ¬ p q  q  p" 
  by (rule ltE,rule not_le_iff_lt[THEN iffD1],auto,drule ltI[of q p],auto,erule leI)

lemmas nat_simp_union = nat_un_max nat_max_ty max_def 

lemma le_succ : "xnat  xsucc(x)" by simp
lemma le_pred : "xnat  pred(x)x" 
  using pred_le[OF _ _ le_succ] pred_succ_eq 
  by simp

lemma Un_le_compat : "o  p  q  r  Ord(o)  Ord(p)  Ord(q)  Ord(r)  o  q  p  r"
  using le_trans[of q r "pr",OF _ Un_upper2_le] le_trans[of o p "pr",OF _ Un_upper1_le]
    nat_simp_union 
  by auto

lemma Un_le : "p  r  q  r 
               Ord(p)  Ord(q)  Ord(r)  
                p  q  r"
  using nat_simp_union by auto

lemma Un_leI3 : "o  r  p  r  q  r  
                Ord(o)  Ord(p)  Ord(q)  Ord(r)  
                o  p  q  r"
  using nat_simp_union by auto

lemma diff_mono :
  assumes "m  nat" "nnat" "p  nat" "m < n" "pm"
  shows "m#-p < n#-p"
proof -
  from assms
  have "m#-p  nat" "m#-p #+p = m"
    using add_diff_inverse2 by simp_all
  with assms
  show ?thesis
    using less_diff_conv[of n p "m #- p",THEN iffD2] by simp
qed

lemma pred_Un:
  "x  nat  y  nat  Arith.pred(succ(x)  y) = x  Arith.pred(y)"
  "x  nat  y  nat  Arith.pred(x  succ(y)) = Arith.pred(x)  y"
  using pred_Un_distrib pred_succ_eq by simp_all

lemma le_natI : "j  n  n  nat  jnat"
  by(drule ltD,rule in_n_in_nat,rule nat_succ_iff[THEN iffD2,of n],simp_all)

lemma le_natE : "nnat  j < n   jn"
  by(rule ltE[of j n],simp+)

lemma diff_cancel :
  assumes "m  nat" "nnat" "m < n"
  shows "m#-n = 0"
  using assms diff_is_0_lemma leI by simp

lemma leD : assumes "nnat" "j  n"
  shows "j < n | j = n"
  using leE[OF jn,of "j<n | j = n"] by auto

subsection‹Some results in ordinal arithmetic›
text‹The following results are auxiliary to the proof of 
wellfoundedness of the relation termfrecR

lemma max_cong :
  assumes "x  y" "Ord(y)" "Ord(z)" shows "max(x,y)  max(y,z)"
  using assms 
proof (cases "y  z")
  case True
  then show ?thesis 
    unfolding max_def using assms by simp
next
  case False
  then have "z  y"  using assms not_le_iff_lt leI by simp
  then show ?thesis 
    unfolding max_def using assms by simp 
qed

lemma max_commutes : 
  assumes "Ord(x)" "Ord(y)"
  shows "max(x,y) = max(y,x)"
  using assms Un_commute nat_simp_union(1) nat_simp_union(1)[symmetric] by auto

lemma max_cong2 :
  assumes "x  y" "Ord(y)" "Ord(z)" "Ord(x)" 
  shows "max(x,z)  max(y,z)"
proof -
  from assms 
  have " x  z  y  z"
    using lt_Ord Ord_Un Un_mono[OF  le_imp_subset[OF xy]]  subset_imp_le by auto
  then show ?thesis 
    using  nat_simp_union ‹Ord(x) ‹Ord(z) ‹Ord(y) by simp
qed

lemma max_D1 :
  assumes "x = y" "w < z"  "Ord(x)"  "Ord(w)" "Ord(z)" "max(x,w) = max(y,z)"
  shows "zy"
proof -
  from assms
  have "w <  x  w" using Un_upper2_lt[OF w<z] assms nat_simp_union by simp
  then
  have "w < x" using assms lt_Un_iff[of x w w] lt_not_refl by auto
  then 
  have "y = y  z" using assms max_commutes nat_simp_union assms leI by simp 
  then 
  show ?thesis using Un_leD2 assms by simp
qed

lemma max_D2 :
  assumes "w = y  w = z" "x < y"  "Ord(x)"  "Ord(w)" "Ord(y)" "Ord(z)" "max(x,w) = max(y,z)"
  shows "x<w"
proof -
  from assms
  have "x < z  y" using Un_upper2_lt[OF x<y] by simp
  then
  consider (a) "x < y" | (b) "x < w"
    using assms nat_simp_union by simp
  then show ?thesis proof (cases)
    case a
    consider (c) "w = y" | (d) "w = z" 
      using assms by auto
    then show ?thesis proof (cases)
      case c
      with a show ?thesis by simp
    next
      case d
      with a
      show ?thesis 
      proof (cases "y <w")
        case True       
        then show ?thesis using lt_trans[OF x<y] by simp
      next
        case False
        then
        have "w  y" 
          using not_lt_iff_le[OF assms(5) assms(4)] by simp
        with w=z
        have "max(z,y) = y"  unfolding max_def using assms by simp
        with assms
        have "... = x  w" using nat_simp_union max_commutes  by simp
        then show ?thesis using le_Un_iff assms by blast
      qed
    qed
  next
    case b
    then show ?thesis .
  qed
qed

lemma oadd_lt_mono2 :
  assumes  "Ord(n)" "Ord(α)" "Ord(β)" "α < β" "x < n" "y < n" "0 <n"
  shows "n ** α ++ x < n **β ++ y"
proof -
  consider (0) "β=0" | (s) γ where  "Ord(γ)" "β = succ(γ)" | (l) "Limit(β)"
    using Ord_cases[OF ‹Ord(β),of ?thesis] by force
  then show ?thesis 
  proof cases
    case 0
    then show ?thesis using α<β by auto
  next
    case s
    then
    have "αγ" using α<β using leI by auto
    then
    have "n ** α  n ** γ" using omult_le_mono[OF _ αγ] ‹Ord(n) by simp
    then
    have "n ** α ++ x < n ** γ ++ n" using oadd_lt_mono[OF _ x<n] by simp
    also
    have "... = n ** β" using β=succ(_) omult_succ ‹Ord(β) ‹Ord(n) by simp
    finally
    have "n ** α ++ x < n ** β" by auto
    then
    show ?thesis using oadd_le_self ‹Ord(β) lt_trans2 ‹Ord(n) by auto
  next
    case l
    have "Ord(x)" using x<n lt_Ord by simp
    with l
    have "succ(α) < β" using Limit_has_succ α<β by simp
    have "n ** α ++ x < n ** α ++ n" 
      using oadd_lt_mono[OF le_refl[OF Ord_omult[OF _ ‹Ord(α)]] x<n] ‹Ord(n) by simp
    also
    have "... = n ** succ(α)" using omult_succ ‹Ord(α) ‹Ord(n) by simp
    finally
    have "n ** α ++ x < n ** succ(α)" by simp 
    with ‹succ(α) < β
    have "n ** α ++ x < n ** β" using lt_trans omult_lt_mono ‹Ord(n) 0<n  by auto      
    then show ?thesis using oadd_le_self ‹Ord(β) lt_trans2 ‹Ord(n) by auto
  qed
qed
end

Theory Internalizations

section‹Aids to internalize formulas›
theory Internalizations
  imports 
    "ZF-Constructible.DPow_absolute" 
begin

text‹We found it useful to have slightly different versions of some 
results in ZF-Constructible:›
lemma nth_closed :
  assumes "0A" "envlist(A)"
  shows "nth(n,env)A" 
  using assms(2,1) unfolding nth_def by (induct env; simp)

lemmas FOL_sats_iff = sats_Nand_iff sats_Forall_iff sats_Neg_iff sats_And_iff
  sats_Or_iff sats_Implies_iff sats_Iff_iff sats_Exists_iff 

lemma nth_ConsI: "nth(n,l) = x; n  nat  nth(succ(n), Cons(a,l)) = x"
by simp

lemmas nth_rules = nth_0 nth_ConsI nat_0I nat_succI
lemmas sep_rules = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
                   fun_plus_iff_sats successor_iff_sats
                    omega_iff_sats FOL_sats_iff Replace_iff_sats

text‹Also a different compilation of lemmas (termsep_rules›) used in formula
 synthesis›
lemmas fm_defs = omega_fm_def limit_ordinal_fm_def empty_fm_def typed_function_fm_def
                 pair_fm_def upair_fm_def domain_fm_def function_fm_def succ_fm_def
                 cons_fm_def fun_apply_fm_def image_fm_def big_union_fm_def union_fm_def
                 relation_fm_def composition_fm_def field_fm_def ordinal_fm_def range_fm_def
                 transset_fm_def subset_fm_def Replace_fm_def


end

Theory Recursion_Thms

section‹Some enhanced theorems on recursion›

theory Recursion_Thms imports ZF.Epsilon begin

text‹We prove results concerning definitions by well-founded
recursion on some relation termR and its transitive closure
termR^*
  (* Restrict the relation r to the field A*A *)

lemma fld_restrict_eq : "a  A  (r  A×A)-``{a} = (r-``{a}  A)"
  by(force)

lemma fld_restrict_mono : "relation(r)  A  B  r  A×A  r  B×B"
  by(auto)

lemma fld_restrict_dom :
  assumes "relation(r)" "domain(r)  A" "range(r) A"
  shows "r A×A = r"
proof (rule equalityI,blast,rule subsetI)
  { fix x
    assume xr: "x  r"
    from xr assms have " a b . x = a,b" by (simp add: relation_def)
    then obtain a b where "a,b  r" "a,b  rA×A" "x  rA×A"
      using assms xr
      by force
    then have "x r  A×A" by simp
  }
  then show "x  r  x rA×A" for x .
qed

definition tr_down :: "[i,i]  i"
  where "tr_down(r,a) = (r^+)-``{a}"

lemma tr_downD : "x  tr_down(r,a)  x,a  r^+"
  by (simp add: tr_down_def vimage_singleton_iff)

lemma pred_down : "relation(r)  r-``{a}  tr_down(r,a)"
  by(simp add: tr_down_def vimage_mono r_subset_trancl)

lemma tr_down_mono : "relation(r)  x  r-``{a}  tr_down(r,x)  tr_down(r,a)"
  by(rule subsetI,simp add:tr_down_def,auto dest: underD,force simp add: underI r_into_trancl trancl_trans)

lemma rest_eq :
  assumes "relation(r)" and "r-``{a}  B" and "a  B"
  shows "r-``{a} = (rB×B)-``{a}"
proof (intro equalityI subsetI)
  fix x
  assume "x  r-``{a}"
  then
  have "x  B" using assms by (simp add: subsetD)
  from x r-``{a}
  have "x,a  r" using underD by simp
  then
  show "x  (rB×B)-``{a}" using xB aB underI by simp
next
  from assms
  show "x  r -`` {a}" if  "x  (r  B×B) -`` {a}" for x
    using vimage_mono that by auto
qed

lemma wfrec_restr_eq : "r' = r  A×A  wfrec[A](r,a,H) = wfrec(r',a,H)"
  by(simp add:wfrec_on_def)

lemma wfrec_restr :
  assumes rr: "relation(r)" and wfr:"wf(r)"
  shows  "a  A  tr_down(r,a)  A  wfrec(r,a,H) = wfrec[A](r,a,H)"
proof (induct a arbitrary:A rule:wf_induct_raw[OF wfr] )
  case (1 a)
  have wfRa : "wf[A](r)"
    using wf_subset wfr wf_on_def Int_lower1 by simp
  from pred_down rr
  have "r -`` {a}  tr_down(r, a)" .
  with 1
  have "r-``{a}  A" by (force simp add: subset_trans)
  {
    fix x
    assume x_a : "x  r-``{a}"
    with r-``{a}  A
    have "x  A" ..
    from pred_down rr
    have b : "r -``{x}  tr_down(r,x)" .
    then
    have "tr_down(r,x)  tr_down(r,a)"
      using tr_down_mono x_a rr by simp
    with 1
    have "tr_down(r,x)  A" using subset_trans by force
    have "x,a  r" using x_a  underD by simp
    with 1 ‹tr_down(r,x)  A x  A
    have "wfrec(r,x,H) = wfrec[A](r,x,H)" by simp
  }
  then
  have "x r-``{a}  wfrec(r,x,H) =  wfrec[A](r,x,H)" for x  .
  then
  have Eq1 :"(λ x  r-``{a} . wfrec(r,x,H)) = (λ x  r-``{a} . wfrec[A](r,x,H))"
    using lam_cong by simp

  from assms
  have "wfrec(r,a,H) = H(a,λ x  r-``{a} . wfrec(r,x,H))" by (simp add:wfrec)
  also
  have "... = H(a,λ x  r-``{a} . wfrec[A](r,x,H))"
    using assms Eq1 by simp
  also from 1 r-``{a}  A
  have "... = H(a,λ x  (rA×A)-``{a} . wfrec[A](r,x,H))"
    using assms rest_eq  by simp
  also from aA
  have "... = H(a,λ x  (r-``{a})A . wfrec[A](r,x,H))"
    using fld_restrict_eq by simp
  also from aA wf[A](r)
  have "... = wfrec[A](r,a,H)" using wfrec_on by simp
  finally show ?case .
qed

lemmas wfrec_tr_down = wfrec_restr[OF _ _ _ subset_refl]

lemma wfrec_trans_restr : "relation(r)  wf(r)  trans(r)  r-``{a}A  a  A 
  wfrec(r, a, H) = wfrec[A](r, a, H)"
  by(subgoal_tac "tr_down(r,a)  A",auto simp add : wfrec_restr tr_down_def trancl_eq_r)


lemma field_trancl : "field(r^+) = field(r)"
  by (blast intro: r_into_trancl dest!: trancl_type [THEN subsetD])

definition
  Rrel :: "[iio,i]  i" where
  "Rrel(R,A)  {zA×A. x y. z = x, y  R(x,y)}"

lemma RrelI : "x  A  y  A  R(x,y)  x,y  Rrel(R,A)"
  unfolding Rrel_def by simp

lemma Rrel_mem: "Rrel(mem,x) = Memrel(x)"
  unfolding Rrel_def Memrel_def ..

lemma relation_Rrel: "relation(Rrel(R,d))"
  unfolding Rrel_def relation_def by simp

lemma field_Rrel: "field(Rrel(R,d))   d"
  unfolding Rrel_def by auto

lemma Rrel_mono : "A  B  Rrel(R,A)  Rrel(R,B)"
  unfolding Rrel_def by blast

lemma Rrel_restr_eq : "Rrel(R,A)  B×B = Rrel(R,AB)"
  unfolding Rrel_def by blast

(* now a consequence of the previous lemmas *)
lemma field_Memrel : "field(Memrel(A))  A"
  (* unfolding field_def using Ordinal.Memrel_type by blast *)
  using Rrel_mem field_Rrel by blast

lemma restrict_trancl_Rrel:
  assumes "R(w,y)"
  shows "restrict(f,Rrel(R,d)-``{y})`w
       = restrict(f,(Rrel(R,d)^+)-``{y})`w"
proof (cases "yd")
  let ?r="Rrel(R,d)" and ?s="(Rrel(R,d))^+"
  case True
  show ?thesis
  proof (cases "wd")
    case True
    with yd assms
    have "w,y?r"
      unfolding Rrel_def by blast
    then
    have "w,y?s"
      using r_subset_trancl[of ?r] relation_Rrel[of R d] by blast
    with w,y?r
    have "w?r-``{y}" "w?s-``{y}"
      using vimage_singleton_iff by simp_all
    then
    show ?thesis by simp
  next
    case False
    then
    have "wdomain(restrict(f,?r-``{y}))"
      using subsetD[OF field_Rrel[of R d]] by auto
    moreover from wd
    have "wdomain(restrict(f,?s-``{y}))"
      using subsetD[OF field_Rrel[of R d], of w] field_trancl[of ?r]
        fieldI1[of w y ?s] by auto
    ultimately
    have "restrict(f,?r-``{y})`w = 0" "restrict(f,?s-``{y})`w = 0"
      unfolding apply_def by auto
    then show ?thesis by simp
  qed
next
  let ?r="Rrel(R,d)"
  let ?s="?r^+"
  case False
  then
  have "?r-``{y}=0"
    unfolding Rrel_def by blast
  then
  have "w?r-``{y}" by simp
  with yd assms
  have "yfield(?s)"
    using field_trancl subsetD[OF field_Rrel[of R d]] by force
  then
  have "w?s-``{y}"
    using vimage_singleton_iff by blast
  with w?r-``{y}
  show ?thesis by simp
qed

lemma restrict_trans_eq:
  assumes "w  y"
  shows "restrict(f,Memrel(eclose({x}))-``{y})`w
       = restrict(f,(Memrel(eclose({x}))^+)-``{y})`w"
  using assms restrict_trancl_Rrel[of mem ] Rrel_mem by (simp)

lemma wf_eq_trancl:
  assumes " f y . H(y,restrict(f,R-``{y})) = H(y,restrict(f,R^+-``{y}))"
  shows  "wfrec(R, x, H) = wfrec(R^+, x, H)" (is "wfrec(?r,_,_) = wfrec(?r',_,_)")
proof -
  have "wfrec(R, x, H) = wftrec(?r^+, x, λy f. H(y, restrict(f,?r-``{y})))"
    unfolding wfrec_def ..
  also
  have " ... = wftrec(?r^+, x, λy f. H(y, restrict(f,(?r^+)-``{y})))"
    using assms by simp
  also
  have " ... =  wfrec(?r^+, x, H)"
    unfolding wfrec_def using trancl_eq_r[OF relation_trancl trans_trancl] by simp
  finally
  show ?thesis .
qed

end

Theory Relative_Univ

section‹Relativization of the cumulative hierarchy›
theory Relative_Univ
  imports
    "ZF-Constructible.Rank"
    Internalizations
    Recursion_Thms

begin

lemma (in M_trivial) powerset_abs' [simp]: 
  assumes
    "M(x)" "M(y)"
  shows
    "powerset(M,x,y)  y = {aPow(x) . M(a)}"
  using powerset_abs assms by simp

lemma Collect_inter_Transset:
  assumes 
    "Transset(M)" "b  M"
  shows
    "{xb . P(x)} = {xb . P(x)}  M"
    using assms unfolding Transset_def
  by (auto)  

lemma (in M_trivial) family_union_closed: "strong_replacement(M, λx y. y = f(x)); M(A); xA. M(f(x))
       M(xA. f(x))"
  using RepFun_closed ..

(* "Vfrom(A,i) ≡ transrec(i, %x f. A ∪ (⋃y∈x. Pow(f`y)))" *)
(* HVfrom is *not* the recursive step for Vfrom. It is the
   relativized version *)
definition
  HVfrom :: "[io,i,i,i]  i" where
  "HVfrom(M,A,x,f)  A  (yx. {aPow(f`y). M(a)})"

(* z = Pow(f`y) *)
definition
  is_powapply :: "[io,i,i,i]  o" where
  "is_powapply(M,f,y,z)  M(z)  (fy[M]. fun_apply(M,f,y,fy)  powerset(M,fy,z))"

(* Trivial lemma *)
lemma is_powapply_closed: "is_powapply(M,f,y,z)  M(z)"
  unfolding is_powapply_def by simp

(* is_Replace(M,A,P,z) ≡ ∀u[M]. u ∈ z ⟷ (∃x[M]. x∈A & P(x,u)) *)
definition
  is_HVfrom :: "[io,i,i,i,i]  o" where
  "is_HVfrom(M,A,x,f,h)  U[M]. R[M].  union(M,A,U,h) 
         big_union(M,R,U)  is_Replace(M,x,is_powapply(M,f),R)" 


definition
  is_Vfrom :: "[io,i,i,i]  o" where
  "is_Vfrom(M,A,i,V)  is_transrec(M,is_HVfrom(M,A),i,V)"

definition
  is_Vset :: "[io,i,i]  o" where
  "is_Vset(M,i,V)  z[M]. empty(M,z)  is_Vfrom(M,z,i,V)"


subsection‹Formula synthesis›

schematic_goal sats_is_powapply_fm_auto:
  assumes
    "fnat" "ynat" "znat" "envlist(A)" "0A"
  shows
    "is_powapply(##A,nth(f, env),nth(y, env),nth(z, env))
     sats(A,?ipa_fm(f,y,z),env)"
  unfolding is_powapply_def is_Collect_def powerset_def subset_def
  using nth_closed assms
   by (simp) (rule sep_rules  | simp)+

schematic_goal is_powapply_iff_sats:
  assumes
    "nth(f,env) = ff" "nth(y,env) = yy" "nth(z,env) = zz" "0A"
    "f  nat"  "y  nat" "z  nat" "env  list(A)"
  shows
       "is_powapply(##A,ff,yy,zz)  sats(A, ?is_one_fm(a,r), env)"
  unfolding ‹nth(f,env) = ff[symmetric] ‹nth(y,env) = yy[symmetric]
    ‹nth(z,env) = zz[symmetric]
  by (rule sats_is_powapply_fm_auto(1); simp add:assms)

(* rank *)
definition
  Hrank :: "[i,i]  i" where
  "Hrank(x,f) = (yx. succ(f`y))"

definition
  PHrank :: "[io,i,i,i]  o" where
  "PHrank(M,f,y,z)  M(z)  (fy[M]. fun_apply(M,f,y,fy)  successor(M,fy,z))"

definition
  is_Hrank :: "[io,i,i,i]  o" where
  "is_Hrank(M,x,f,hc)  (R[M]. big_union(M,R,hc) is_Replace(M,x,PHrank(M,f),R)) "

definition
  rrank :: "i  i" where
  "rrank(a)  Memrel(eclose({a}))^+" 

lemma (in M_eclose) wf_rrank : "M(x)  wf(rrank(x))" 
  unfolding rrank_def using wf_trancl[OF wf_Memrel] .

lemma (in M_eclose) trans_rrank : "M(x)  trans(rrank(x))"
  unfolding rrank_def using trans_trancl .

lemma (in M_eclose) relation_rrank : "M(x)  relation(rrank(x))" 
  unfolding rrank_def using relation_trancl .

lemma (in M_eclose) rrank_in_M : "M(x)  M(rrank(x))" 
  unfolding rrank_def by simp


subsection‹Absoluteness results›

locale M_eclose_pow = M_eclose + 
  assumes
    power_ax : "power_ax(M)" and
    powapply_replacement : "M(f)  strong_replacement(M,is_powapply(M,f))" and
    HVfrom_replacement : " M(i) ; M(A)   
                          transrec_replacement(M,is_HVfrom(M,A),i)" and
    PHrank_replacement : "M(f)  strong_replacement(M,PHrank(M,f))" and
    is_Hrank_replacement : "M(x)  wfrec_replacement(M,is_Hrank(M),rrank(x))"

begin

lemma is_powapply_abs: "M(f); M(y)  is_powapply(M,f,y,z)  M(z)  z = {xPow(f`y). M(x)}"
  unfolding is_powapply_def by simp

lemma "M(A); M(x); M(f); M(h)   
      is_HVfrom(M,A,x,f,h)  
      (R[M]. h = A  R  is_Replace(M, x,λx y. y = {x  Pow(f ` x) . M(x)}, R))"
  using is_powapply_abs unfolding is_HVfrom_def by auto

lemma Replace_is_powapply:
  assumes
    "M(R)" "M(A)" "M(f)" 
  shows
  "is_Replace(M, A, is_powapply(M, f), R)  R = Replace(A,is_powapply(M,f))"
proof -
  have "univalent(M,A,is_powapply(M,f))" 
    using M(A) M(f) unfolding univalent_def is_powapply_def by simp
  moreover
  have "x y.  xA; is_powapply(M,f,x,y)   M(y)"
    using M(A) M(f) unfolding is_powapply_def by simp
  ultimately
  show ?thesis using M(A) M(R) Replace_abs by simp
qed

lemma powapply_closed:
  " M(y) ; M(f)   M({x  Pow(f ` y) . M(x)})"
  using apply_closed power_ax unfolding power_ax_def by simp

lemma RepFun_is_powapply:
  assumes
    "M(R)" "M(A)" "M(f)" 
  shows
  "Replace(A,is_powapply(M,f)) = RepFun(A,λy.{xPow(f`y). M(x)})"
proof -
  have "{y . x  A, M(y)  y = {x  Pow(f ` x) . M(x)}} = {y . x  A, y = {x  Pow(f ` x) . M(x)}}"
    using assms powapply_closed transM[of _ A] by blast
  also
  have " ... = {{x  Pow(f ` y) . M(x)} . y  A}" by auto
  finally 
  show ?thesis using assms is_powapply_abs transM[of _ A] by simp
qed

lemma RepFun_powapply_closed:
  assumes 
    "M(f)" "M(A)"
  shows 
    "M(Replace(A,is_powapply(M,f)))"
proof -
  have "univalent(M,A,is_powapply(M,f))" 
    using M(A) M(f) unfolding univalent_def is_powapply_def by simp
  moreover
  have " xA ; is_powapply(M,f,x,y)   M(y)" for x y
    using assms unfolding is_powapply_def by simp
  ultimately
  show ?thesis using assms powapply_replacement by simp
qed

lemma Union_powapply_closed:
  assumes 
    "M(x)" "M(f)"
  shows 
    "M(yx. {aPow(f`y). M(a)})"
proof -
  have "M({aPow(f`y). M(a)})" if "yx" for y
    using that assms transM[of _ x] powapply_closed by simp
  then
  have "M({{aPow(f`y). M(a)}. yx})"
    using assms transM[of _ x]  RepFun_powapply_closed RepFun_is_powapply by simp
  then show ?thesis using assms by simp
qed

lemma relation2_HVfrom: "M(A)  relation2(M,is_HVfrom(M,A),HVfrom(M,A))"
    unfolding is_HVfrom_def HVfrom_def relation2_def
    using Replace_is_powapply RepFun_is_powapply 
          Union_powapply_closed RepFun_powapply_closed by auto

lemma HVfrom_closed : 
  "M(A)  x[M]. g[M]. function(g)  M(HVfrom(M,A,x,g))"
  unfolding HVfrom_def using Union_powapply_closed by simp

lemma transrec_HVfrom:
  assumes "M(A)"
  shows "Ord(i)  {xVfrom(A,i). M(x)} = transrec(i,HVfrom(M,A))"
proof (induct rule:trans_induct)
  case (step i)
  have "Vfrom(A,i) = A  (yi. Pow((λxi. Vfrom(A, x)) ` y))"
    using def_transrec[OF Vfrom_def, of A i] by simp
  then 
  have "Vfrom(A,i) = A  (yi. Pow(Vfrom(A, y)))"
    by simp
  then
  have "{xVfrom(A,i). M(x)} = {xA. M(x)}  (yi. {xPow(Vfrom(A, y)). M(x)})"
    by auto
  with M(A)
  have "{xVfrom(A,i). M(x)} = A  (yi. {xPow(Vfrom(A, y)). M(x)})" 
    by (auto intro:transM)
  also
  have "... = A  (yi. {xPow({zVfrom(A,y). M(z)}). M(x)})" 
  proof -
    have "{xPow(Vfrom(A, y)). M(x)} = {xPow({zVfrom(A,y). M(z)}). M(x)}"
      if "yi" for y by (auto intro:transM)
    then
    show ?thesis by simp
  qed
  also from step 
  have " ... = A  (yi. {xPow(transrec(y, HVfrom(M, A))). M(x)})" by auto
  also
  have " ... = transrec(i, HVfrom(M, A))"
    using def_transrec[of "λy. transrec(y, HVfrom(M, A))" "HVfrom(M, A)" i,symmetric] 
    unfolding HVfrom_def by simp
  finally
  show ?case .
qed

lemma Vfrom_abs: " M(A); M(i); M(V); Ord(i)   is_Vfrom(M,A,i,V)  V = {xVfrom(A,i). M(x)}"
  unfolding is_Vfrom_def
  using relation2_HVfrom HVfrom_closed HVfrom_replacement 
    transrec_abs[of "is_HVfrom(M,A)" i "HVfrom(M,A)"] transrec_HVfrom by simp

lemma Vfrom_closed: " M(A); M(i); Ord(i)   M({xVfrom(A,i). M(x)})"
  unfolding is_Vfrom_def
  using relation2_HVfrom HVfrom_closed HVfrom_replacement 
    transrec_closed[of "is_HVfrom(M,A)" i "HVfrom(M,A)"] transrec_HVfrom by simp

lemma Vset_abs: " M(i); M(V); Ord(i)   is_Vset(M,i,V)  V = {xVset(i). M(x)}"
  using Vfrom_abs unfolding is_Vset_def by simp

lemma Vset_closed: " M(i); Ord(i)   M({xVset(i). M(x)})"
  using Vfrom_closed unfolding is_Vset_def by simp

lemma Hrank_trancl:"Hrank(y, restrict(f,Memrel(eclose({x}))-``{y}))
                  = Hrank(y, restrict(f,(Memrel(eclose({x}))^+)-``{y}))"
  unfolding Hrank_def
  using restrict_trans_eq by simp

lemma rank_trancl: "rank(x) = wfrec(rrank(x), x, Hrank)"
proof -
  have "rank(x) =  wfrec(Memrel(eclose({x})), x, Hrank)"
    (is "_ = wfrec(?r,_,_)")
    unfolding rank_def transrec_def Hrank_def by simp
  also
  have " ... = wftrec(?r^+, x, λy f. Hrank(y, restrict(f,?r-``{y})))"
    unfolding wfrec_def ..
  also
  have " ... = wftrec(?r^+, x, λy f. Hrank(y, restrict(f,(?r^+)-``{y})))"
    using Hrank_trancl by simp
  also
  have " ... =  wfrec(?r^+, x, Hrank)"
    unfolding wfrec_def using trancl_eq_r[OF relation_trancl trans_trancl] by simp
  finally
  show ?thesis unfolding rrank_def .
qed

lemma univ_PHrank : " M(z) ; M(f)   univalent(M,z,PHrank(M,f))" 
  unfolding univalent_def PHrank_def by simp


lemma PHrank_abs :
    " M(f) ; M(y)   PHrank(M,f,y,z)  M(z)  z = succ(f`y)"
  unfolding PHrank_def by simp

lemma PHrank_closed : "PHrank(M,f,y,z)  M(z)" 
  unfolding PHrank_def by simp

lemma Replace_PHrank_abs:
  assumes
    "M(z)" "M(f)" "M(hr)" 
  shows
    "is_Replace(M,z,PHrank(M,f),hr)  hr = Replace(z,PHrank(M,f))" 
proof -
  have "x y. xz; PHrank(M,f,x,y)   M(y)"
    using M(z) M(f) unfolding PHrank_def by simp
  then
  show ?thesis using M(z) M(hr) M(f) univ_PHrank Replace_abs by simp
qed

lemma RepFun_PHrank:
  assumes
    "M(R)" "M(A)" "M(f)" 
  shows
  "Replace(A,PHrank(M,f)) = RepFun(A,λy. succ(f`y))"
proof -
  have "{z . y  A, M(z)  z = succ(f`y)} = {z . y  A, z = succ(f`y)}" 
    using assms PHrank_closed transM[of _ A] by blast
  also
  have " ... = {succ(f`y) . y  A}" by auto
  finally 
  show ?thesis using assms PHrank_abs transM[of _ A] by simp
qed

lemma RepFun_PHrank_closed :
  assumes
    "M(f)" "M(A)" 
  shows
    "M(Replace(A,PHrank(M,f)))"
proof -
  have " xA ; PHrank(M,f,x,y)   M(y)" for x y
    using assms unfolding PHrank_def by simp
  with univ_PHrank
  show ?thesis using assms PHrank_replacement by simp
qed

lemma relation2_Hrank :
  "relation2(M,is_Hrank(M),Hrank)"
  unfolding is_Hrank_def Hrank_def relation2_def
  using Replace_PHrank_abs RepFun_PHrank RepFun_PHrank_closed by auto


lemma Union_PHrank_closed:
  assumes 
    "M(x)" "M(f)"
  shows 
    "M(yx. succ(f`y))"
proof -
  have "M(succ(f`y))" if "yx" for y
    using that assms transM[of _ x] by simp
  then
  have "M({succ(f`y). yx})"
    using assms transM[of _ x]  RepFun_PHrank_closed RepFun_PHrank by simp
  then show ?thesis using assms by simp
qed

lemma is_Hrank_closed : 
  "M(A)  x[M]. g[M]. function(g)  M(Hrank(x,g))"
  unfolding Hrank_def using RepFun_PHrank_closed Union_PHrank_closed by simp

lemma rank_closed: "M(a)  M(rank(a))"
  unfolding rank_trancl 
  using relation2_Hrank is_Hrank_closed is_Hrank_replacement 
        wf_rrank relation_rrank trans_rrank rrank_in_M 
         trans_wfrec_closed[of "rrank(a)" a "is_Hrank(M)"] by simp


lemma M_into_Vset:
  assumes "M(a)"
  shows "i[M]. V[M]. ordinal(M,i)  is_Vfrom(M,0,i,V)  aV"
proof -
  let ?i="succ(rank(a))"
  from assms
  have "a{xVfrom(0,?i). M(x)}" (is "a?V")
    using Vset_Ord_rank_iff by simp
  moreover from assms
  have "M(?i)"
    using rank_closed by simp
  moreover 
  note M(a)
  moreover from calculation
  have "M(?V)"
    using Vfrom_closed by simp
  moreover from calculation
  have "ordinal(M,?i)  is_Vfrom(M, 0, ?i, ?V)  a  ?V"
    using Ord_rank Vfrom_abs by simp 
  ultimately
  show ?thesis by blast
qed

end
end

Theory Synthetic_Definition

section‹Automatic synthesis of formulas›

theory Synthetic_Definition
  imports Utils
  keywords "synthesize" :: thy_decl % "ML"
    and "synthesize_notc" :: thy_decl % "ML"
    and "from_schematic"
begin

MLval $` = curry ((op $) o swap)
infix $`

fun pair f g x = (f x, g x)

fun display kind pos (thms,thy) =
  let val _ = Proof_Display.print_results true pos thy ((kind,""),[thms])
  in thy
end

fun prove_tc_form goal thms ctxt =
  Goal.prove ctxt [] [] goal
     (fn _ => rewrite_goal_tac ctxt thms 1
              THEN TypeCheck.typecheck_tac ctxt)

fun prove_sats goal thms thm_auto ctxt =
  let val ctxt' = ctxt |> Simplifier.add_simp (thm_auto |> hd)
  in
  Goal.prove ctxt [] [] goal
     (fn _ => rewrite_goal_tac ctxt thms 1
              THEN PARALLEL_ALLGOALS (asm_simp_tac ctxt')
              THEN TypeCheck.typecheck_tac ctxt')
  end

fun is_mem (@{const mem} $ _ $  _) = true
  | is_mem _ = false

fun synth_thm_sats def_name term lhs set env hyps vars vs pos thm_auto lthy =
let val (_,tm,ctxt1) = Utils.thm_concl_tm lthy term
    val (thm_refs,ctxt2) = Variable.import true [Proof_Context.get_thm lthy term] ctxt1 |>> #2
    val vs' = map (Thm.term_of o #2) vs
    val vars' = map (Thm.term_of o #2) vars
    val r_tm = tm |> Utils.dest_lhs_def |> fold (op $`) vs'
    val sats = @{const apply} $ (@{const satisfies} $ set $ r_tm) $ env
    val rhs = @{const IFOL.eq(i)} $ sats $ (@{const succ} $ @{const zero})
    val concl = @{const IFOL.iff} $ lhs $ rhs
    val g_iff = Logic.list_implies(hyps, Utils.tp concl)
    val thm = prove_sats g_iff thm_refs thm_auto ctxt2
    val name = Binding.name (def_name ^ "_iff_sats")
    val thm = Utils.fix_vars thm (map (#1 o dest_Free) vars') lthy
 in
   Local_Theory.note ((name, []), [thm]) lthy |> display "theorem" pos
 end

fun synth_thm_tc def_name term hyps vars pos lthy =
let val (_,tm,ctxt1) = Utils.thm_concl_tm lthy term
    val (thm_refs,ctxt2) = Variable.import true [Proof_Context.get_thm lthy term] ctxt1
                    |>> #2
    val vars' = map (Thm.term_of o #2) vars
    val tc_attrib = @{attributes [TC]}
    val r_tm = tm |> Utils.dest_lhs_def |> fold (op $`) vars'
    val concl = @{const mem} $ r_tm $ @{const formula}
    val g = Logic.list_implies(hyps, Utils.tp concl)
    val thm = prove_tc_form g thm_refs ctxt2
    val name = Binding.name (def_name ^ "_type")
    val thm = Utils.fix_vars thm (map (#1 o dest_Free) vars') ctxt2
 in
   Local_Theory.note ((name, tc_attrib), [thm]) lthy |> display "theorem" pos
 end


fun synthetic_def def_name thmref pos tc auto thy =
  let
    val (thm_ref,_) = thmref |>> Facts.ref_name
    val (((_,vars),thm_tms),_) = Variable.import true [Proof_Context.get_thm thy thm_ref] thy
    val (tm,hyps) = thm_tms |> hd |> pair Thm.concl_of Thm.prems_of
    val (lhs,rhs) = tm |> Utils.dest_iff_tms o Utils.dest_trueprop
    val ((set,t),env) = rhs |> Utils.dest_sats_frm
    fun olist t = Ord_List.make String.compare (Term.add_free_names t [])
    fun relevant ts (@{const mem} $ t $ _) = not (Term.is_Free t) orelse
        Ord_List.member String.compare ts (t |> Term.dest_Free |> #1)
      | relevant _ _ = false
    val t_vars = olist t
    val vs = List.filter (fn (((v,_),_),_) => Utils.inList v t_vars) vars
    val at = List.foldr (fn ((_,var),t') => lambda (Thm.term_of var) t') t vs
    val hyps' = List.filter (relevant t_vars o Utils.dest_trueprop) hyps
  in
    Local_Theory.define ((Binding.name def_name, NoSyn),
                        ((Binding.name (def_name ^ "_def"), []), at)) thy |> #2 |>
    (if tc then synth_thm_tc def_name (def_name ^ "_def") hyps' vs pos else I) |>
    (if auto then synth_thm_sats def_name (def_name ^ "_def") lhs set env hyps vars vs pos thm_tms else I)

end
MLlocal
  val synth_constdecl =
       Parse.position (Parse.string -- ((Parse.$$$ "from_schematic" |-- Parse.thm)));

  val _ =
     Outer_Syntax.local_theory command_keywordsynthesize "ML setup for synthetic definitions"
       (synth_constdecl >> (fn ((bndg,thm),p) => synthetic_def bndg thm p true true))

  val _ =
     Outer_Syntax.local_theory command_keywordsynthesize_notc "ML setup for synthetic definitions"
       (synth_constdecl >> (fn ((bndg,thm),p) => synthetic_def bndg thm p false false))

in

end
text‹The MLsynthetic_def function extracts definitions from
schematic goals. A new definition is added to the context. ›

(* example of use *)
(*
schematic_goal mem_formula_ex :
  assumes "m∈nat" "n∈ nat" "env ∈ list(M)"
  shows "nth(m,env) ∈ nth(n,env) ⟷ sats(M,?frm,env)"
  by (insert assms ; (rule sep_rules empty_iff_sats cartprod_iff_sats | simp del:sats_cartprod_fm)+)

synthesize "φ" from_schematic mem_formula_ex
*)

end

Theory Interface

section‹Interface between set models and Constructibility›

text‹This theory provides an interface between Paulson's
relativization results and set models of ZFC. In particular,
it is used to prove that the locale termforcing_data is
a sublocale of all relevant locales in ZF-Constructibility
(termM_trivial, termM_basic, termM_eclose, etc).›

theory Interface
  imports
    Nat_Miscellanea
    Relative_Univ
    Synthetic_Definition
begin

syntax
  "_sats"  :: "[i, i, i]  o"  ("(_, _  _)" [36,36,36] 60)
translations
  "(M,env  φ)"  "CONST sats(M,φ,env)"

abbreviation
  dec10  :: i   ("10") where "10  succ(9)"

abbreviation
  dec11  :: i   ("11") where "11  succ(10)"

abbreviation
  dec12  :: i   ("12") where "12  succ(11)"

abbreviation
  dec13  :: i   ("13") where "13  succ(12)"

abbreviation
  dec14  :: i   ("14") where "14  succ(13)"


definition
  infinity_ax :: "(i  o)  o" where
  "infinity_ax(M) 
      (I[M]. (z[M]. empty(M,z)  zI)  (y[M]. yI  (sy[M]. successor(M,y,sy)  syI)))"

definition
  choice_ax :: "(io)  o" where
  "choice_ax(M)  x[M]. a[M]. f[M]. ordinal(M,a)  surjection(M,a,x,f)"

context M_basic begin

lemma choice_ax_abs :
  "choice_ax(M)  (x[M]. a[M]. f[M]. Ord(a)  f  surj(a,x))"
  unfolding choice_ax_def
  by (simp)

end (* M_basic *)

definition
  wellfounded_trancl :: "[i=>o,i,i,i] => o" where
  "wellfounded_trancl(M,Z,r,p) 
      w[M]. wx[M]. rp[M].
               w  Z & pair(M,w,p,wx) & tran_closure(M,r,rp) & wx  rp"

lemma empty_intf :
  "infinity_ax(M) 
  (z[M]. empty(M,z))"
  by (auto simp add: empty_def infinity_ax_def)

lemma Transset_intf :
  "Transset(M)   yx  x  M  y  M"
  by (simp add: Transset_def,auto)

locale M_ZF_trans =
  fixes M
  assumes
    upair_ax:         "upair_ax(##M)"
    and Union_ax:         "Union_ax(##M)"
    and power_ax:         "power_ax(##M)"
    and extensionality:   "extensionality(##M)"
    and foundation_ax:    "foundation_ax(##M)"
    and infinity_ax:      "infinity_ax(##M)"
    and separation_ax:    "φformula  envlist(M)  arity(φ)  1 #+ length(env) 
                    separation(##M,λx. sats(M,φ,[x] @ env))"
    and replacement_ax:   "φformula  envlist(M)  arity(φ)  2 #+ length(env) 
                    strong_replacement(##M,λx y. sats(M,φ,[x,y] @ env))"
    and trans_M:          "Transset(M)"
begin


lemma TranssetI :
  "(y x. yx  xM  yM)  Transset(M)"
  by (auto simp add: Transset_def)

lemma zero_in_M:  "0  M"
proof -
  from infinity_ax have
    "(z[##M]. empty(##M,z))"
    by (rule empty_intf)
  then obtain z where
    zm: "empty(##M,z)"  "zM"
    by auto
  with trans_M have "z=0"
    by (simp  add: empty_def, blast intro: Transset_intf )
  with zm show ?thesis
    by simp
qed

subsection‹Interface with term‹M_trivial›
lemma mtrans :
  "M_trans(##M)"
  using Transset_intf[OF trans_M] zero_in_M exI[of "λx. xM"]
  by unfold_locales auto


lemma mtriv :
  "M_trivial(##M)"
  using trans_M M_trivial.intro mtrans M_trivial_axioms.intro upair_ax Union_ax
  by simp

end

sublocale M_ZF_trans  M_trivial "##M"
  by (rule mtriv)

context M_ZF_trans
begin

subsection‹Interface with term‹M_basic›

(* Inter_separation: "M(A) ⟹ separation(M, λx. ∀ y[M]. y∈A ⟹ x∈y)" *)
schematic_goal inter_fm_auto:
  assumes
    "nth(i,env) = x" "nth(j,env) = B"
    "i  nat" "j  nat" "env  list(A)"
  shows
    "(yA . yB  xy)  sats(A,?ifm(i,j),env)"
  by (insert assms ; (rule sep_rules | simp)+)

lemma inter_sep_intf :
  assumes
    "AM"
  shows
    "separation(##M,λx . yM . yA  xy)"
proof -
  obtain ifm where
    fmsats:"env. envlist(M)  ( yM. y(nth(1,env))  nth(0,env)y)
     sats(M,ifm(0,1),env)"
    and
    "ifm(0,1)  formula"
    and
    "arity(ifm(0,1)) = 2"
    using AM inter_fm_auto
    by (simp del:FOL_sats_iff add: nat_simp_union)
  then
  have "aM. separation(##M, λx. sats(M,ifm(0,1) , [x, a]))"
    using separation_ax by simp
  moreover
  have "(yM . ya  xy)  sats(M,ifm(0,1),[x,a])"
    if "aM" "xM" for a x
    using that fmsats[of "[x,a]"] by simp
  ultimately
  have "aM. separation(##M, λx . yM . ya  xy)"
    unfolding separation_def by simp
  with AM show ?thesis by simp
qed


(* Diff_separation: "M(B) ⟹ separation(M, λx. x ∉ B)" *)
schematic_goal diff_fm_auto:
  assumes
    "nth(i,env) = x" "nth(j,env) = B"
    "i  nat" "j  nat" "env  list(A)"
  shows
    "xB  sats(A,?dfm(i,j),env)"
  by (insert assms ; (rule sep_rules | simp)+)

lemma diff_sep_intf :
  assumes
    "BM"
  shows
    "separation(##M,λx . xB)"
proof -
  obtain dfm where
    fmsats:"env. envlist(M)  nth(0,env)nth(1,env)
     sats(M,dfm(0,1),env)"
    and
    "dfm(0,1)  formula"
    and
    "arity(dfm(0,1)) = 2"
    using BM diff_fm_auto
    by (simp del:FOL_sats_iff add: nat_simp_union)
  then
  have "bM. separation(##M, λx. sats(M,dfm(0,1) , [x, b]))"
    using separation_ax by simp
  moreover
  have "xb  sats(M,dfm(0,1),[x,b])"
    if "bM" "xM" for b x
    using that fmsats[of "[x,b]"] by simp
  ultimately
  have "bM. separation(##M, λx . xb)"
    unfolding separation_def by simp
  with BM show ?thesis by simp
qed

schematic_goal cprod_fm_auto:
  assumes
    "nth(i,env) = z" "nth(j,env) = B" "nth(h,env) = C"
    "i  nat" "j  nat" "h  nat" "env  list(A)"
  shows
    "(xA. xB  (yA. yC  pair(##A,x,y,z)))  sats(A,?cpfm(i,j,h),env)"
  by (insert assms ; (rule sep_rules | simp)+)


lemma cartprod_sep_intf :
  assumes
    "AM"
    and
    "BM"
  shows
    "separation(##M,λz. xM. xA  (yM. yB  pair(##M,x,y,z)))"
proof -
  obtain cpfm where
    fmsats:"env. envlist(M) 
    (xM. xnth(1,env)  (yM. ynth(2,env)  pair(##M,x,y,nth(0,env))))
     sats(M,cpfm(0,1,2),env)"
    and
    "cpfm(0,1,2)  formula"
    and
    "arity(cpfm(0,1,2)) = 3"
    using cprod_fm_auto by (simp del:FOL_sats_iff add: fm_defs nat_simp_union)
  then
  have "aM. bM. separation(##M, λz. sats(M,cpfm(0,1,2) , [z, a, b]))"
    using separation_ax by simp
  moreover
  have "(xM. xa  (yM. yb  pair(##M,x,y,z)))  sats(M,cpfm(0,1,2),[z,a,b])"
    if "aM" "bM" "zM" for a b z
    using that fmsats[of "[z,a,b]"] by simp
  ultimately
  have "aM. bM. separation(##M, λz . (xM. xa  (yM. yb  pair(##M,x,y,z))))"
    unfolding separation_def by simp
  with AM BM show ?thesis by simp
qed

schematic_goal im_fm_auto:
  assumes
    "nth(i,env) = y" "nth(j,env) = r" "nth(h,env) = B"
    "i  nat" "j  nat" "h  nat" "env  list(A)"
  shows
    "(pA. pr & (xA. xB & pair(##A,x,y,p)))  sats(A,?imfm(i,j,h),env)"
  by (insert assms ; (rule sep_rules | simp)+)

lemma image_sep_intf :
  assumes
    "AM"
    and
    "rM"
  shows
    "separation(##M, λy. pM. pr & (xM. xA & pair(##M,x,y,p)))"
proof -
  obtain imfm where
    fmsats:"env. envlist(M) 
    (pM. pnth(1,env) & (xM. xnth(2,env) & pair(##M,x,nth(0,env),p)))
     sats(M,imfm(0,1,2),env)"
    and
    "imfm(0,1,2)  formula"
    and
    "arity(imfm(0,1,2)) = 3"
    using im_fm_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "rM. aM. separation(##M, λy. sats(M,imfm(0,1,2) , [y,r,a]))"
    using separation_ax by simp
  moreover
  have "(pM. pk & (xM. xa & pair(##M,x,y,p)))  sats(M,imfm(0,1,2),[y,k,a])"
    if "kM" "aM" "yM" for k a y
    using that fmsats[of "[y,k,a]"] by simp
  ultimately
  have "kM. aM. separation(##M, λy . pM. pk & (xM. xa & pair(##M,x,y,p)))"
    unfolding separation_def by simp
  with rM AM show ?thesis by simp
qed

schematic_goal con_fm_auto:
  assumes
    "nth(i,env) = z" "nth(j,env) = R"
    "i  nat" "j  nat" "env  list(A)"
  shows
    "(pA. pR & (xA.yA. pair(##A,x,y,p) & pair(##A,y,x,z)))
   sats(A,?cfm(i,j),env)"
  by (insert assms ; (rule sep_rules | simp)+)


lemma converse_sep_intf :
  assumes
    "RM"
  shows
    "separation(##M,λz. pM. pR & (xM.yM. pair(##M,x,y,p) & pair(##M,y,x,z)))"
proof -
  obtain cfm where
    fmsats:"env. envlist(M) 
    (pM. pnth(1,env) & (xM.yM. pair(##M,x,y,p) & pair(##M,y,x,nth(0,env))))
     sats(M,cfm(0,1),env)"
    and
    "cfm(0,1)  formula"
    and
    "arity(cfm(0,1)) = 2"
    using con_fm_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "rM. separation(##M, λz. sats(M,cfm(0,1) , [z,r]))"
    using separation_ax by simp
  moreover
  have "(pM. pr & (xM.yM. pair(##M,x,y,p) & pair(##M,y,x,z))) 
          sats(M,cfm(0,1),[z,r])"
    if "zM" "rM" for z r
    using that fmsats[of "[z,r]"] by simp
  ultimately
  have "rM. separation(##M, λz . pM. pr & (xM.yM. pair(##M,x,y,p) & pair(##M,y,x,z)))"
    unfolding separation_def by simp
  with RM show ?thesis by simp
qed


schematic_goal rest_fm_auto:
  assumes
    "nth(i,env) = z" "nth(j,env) = C"
    "i  nat" "j  nat" "env  list(A)"
  shows
    "(xA. xC & (yA. pair(##A,x,y,z)))
   sats(A,?rfm(i,j),env)"
  by (insert assms ; (rule sep_rules | simp)+)


lemma restrict_sep_intf :
  assumes
    "AM"
  shows
    "separation(##M,λz. xM. xA & (yM. pair(##M,x,y,z)))"
proof -
  obtain rfm where
    fmsats:"env. envlist(M) 
    (xM. xnth(1,env) & (yM. pair(##M,x,y,nth(0,env))))
     sats(M,rfm(0,1),env)"
    and
    "rfm(0,1)  formula"
    and
    "arity(rfm(0,1)) = 2"
    using rest_fm_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "aM. separation(##M, λz. sats(M,rfm(0,1) , [z,a]))"
    using separation_ax by simp
  moreover
  have "(xM. xa & (yM. pair(##M,x,y,z))) 
          sats(M,rfm(0,1),[z,a])"
    if "zM" "aM" for z a
    using that fmsats[of "[z,a]"] by simp
  ultimately
  have "aM. separation(##M, λz . xM. xa & (yM. pair(##M,x,y,z)))"
    unfolding separation_def by simp
  with AM show ?thesis by simp
qed

schematic_goal comp_fm_auto:
  assumes
    "nth(i,env) = xz" "nth(j,env) = S" "nth(h,env) = R"
    "i  nat" "j  nat" "h  nat" "env  list(A)"
  shows
    "(xA. yA. zA. xyA. yzA.
              pair(##A,x,z,xz) & pair(##A,x,y,xy) & pair(##A,y,z,yz) & xyS & yzR)
   sats(A,?cfm(i,j,h),env)"
  by (insert assms ; (rule sep_rules | simp)+)


lemma comp_sep_intf :
  assumes
    "RM"
    and
    "SM"
  shows
    "separation(##M,λxz. xM. yM. zM. xyM. yzM.
              pair(##M,x,z,xz) & pair(##M,x,y,xy) & pair(##M,y,z,yz) & xyS & yzR)"
proof -
  obtain cfm where
    fmsats:"env. envlist(M) 
    (xM. yM. zM. xyM. yzM. pair(##M,x,z,nth(0,env)) &
            pair(##M,x,y,xy) & pair(##M,y,z,yz) & xynth(1,env) & yznth(2,env))
     sats(M,cfm(0,1,2),env)"
    and
    "cfm(0,1,2)  formula"
    and
    "arity(cfm(0,1,2)) = 3"
    using comp_fm_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "rM. sM. separation(##M, λy. sats(M,cfm(0,1,2) , [y,s,r]))"
    using separation_ax by simp
  moreover
  have "(xM. yM. zM. xyM. yzM.
              pair(##M,x,z,xz) & pair(##M,x,y,xy) & pair(##M,y,z,yz) & xys & yzr)
           sats(M,cfm(0,1,2) , [xz,s,r])"
    if "xzM" "sM" "rM" for xz s r
    using that fmsats[of "[xz,s,r]"] by simp
  ultimately
  have "sM. rM. separation(##M, λxz . xM. yM. zM. xyM. yzM.
              pair(##M,x,z,xz) & pair(##M,x,y,xy) & pair(##M,y,z,yz) & xys & yzr)"
    unfolding separation_def by simp
  with SM RM show ?thesis by simp
qed


schematic_goal pred_fm_auto:
  assumes
    "nth(i,env) = y" "nth(j,env) = R" "nth(h,env) = X"
    "i  nat" "j  nat" "h  nat" "env  list(A)"
  shows
    "(pA. pR & pair(##A,y,X,p))  sats(A,?pfm(i,j,h),env)"
  by (insert assms ; (rule sep_rules | simp)+)


lemma pred_sep_intf:
  assumes
    "RM"
    and
    "XM"
  shows
    "separation(##M, λy. pM. pR & pair(##M,y,X,p))"
proof -
  obtain pfm where
    fmsats:"env. envlist(M) 
    (pM. pnth(1,env) & pair(##M,nth(0,env),nth(2,env),p))  sats(M,pfm(0,1,2),env)"
    and
    "pfm(0,1,2)  formula"
    and
    "arity(pfm(0,1,2)) = 3"
    using pred_fm_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "xM. rM. separation(##M, λy. sats(M,pfm(0,1,2) , [y,r,x]))"
    using separation_ax by simp
  moreover
  have "(pM. pr & pair(##M,y,x,p))
           sats(M,pfm(0,1,2) , [y,r,x])"
    if "yM" "rM" "xM" for y x r
    using that fmsats[of "[y,r,x]"] by simp
  ultimately
  have "xM. rM. separation(##M, λ y . pM. pr & pair(##M,y,x,p))"
    unfolding separation_def by simp
  with XM RM show ?thesis by simp
qed

(* Memrel_separation:
     "separation(M, λz. ∃x[M]. ∃y[M]. pair(M,x,y,z) & x ∈ y)"
*)
schematic_goal mem_fm_auto:
  assumes
    "nth(i,env) = z" "i  nat" "env  list(A)"
  shows
    "(xA. yA. pair(##A,x,y,z) & x  y)  sats(A,?mfm(i),env)"
  by (insert assms ; (rule sep_rules | simp)+)

lemma memrel_sep_intf:
  "separation(##M, λz. xM. yM. pair(##M,x,y,z) & x  y)"
proof -
  obtain mfm where
    fmsats:"env. envlist(M) 
    (xM. yM. pair(##M,x,y,nth(0,env)) & x  y)  sats(M,mfm(0),env)"
    and
    "mfm(0)  formula"
    and
    "arity(mfm(0)) = 1"
    using mem_fm_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "separation(##M, λz. sats(M,mfm(0) , [z]))"
    using separation_ax by simp
  moreover
  have "(xM. yM. pair(##M,x,y,z) & x  y)  sats(M,mfm(0),[z])"
    if "zM" for z
    using that fmsats[of "[z]"] by simp
  ultimately
  have "separation(##M, λz . xM. yM. pair(##M,x,y,z) & x  y)"
    unfolding separation_def by simp
  then show ?thesis by simp
qed

schematic_goal recfun_fm_auto:
  assumes
    "nth(i1,env) = x" "nth(i2,env) = r" "nth(i3,env) = f" "nth(i4,env) = g" "nth(i5,env) = a"
    "nth(i6,env) = b" "i1nat" "i2nat" "i3nat" "i4nat" "i5nat" "i6nat" "env  list(A)"
  shows
    "(xaA. xbA. pair(##A,x,a,xa) & xa  r & pair(##A,x,b,xb) & xb  r &
                  (fxA. gxA. fun_apply(##A,f,x,fx) & fun_apply(##A,g,x,gx) & fx  gx))
     sats(A,?rffm(i1,i2,i3,i4,i5,i6),env)"
  by (insert assms ; (rule sep_rules | simp)+)


lemma is_recfun_sep_intf :
  assumes
    "rM" "fM" "gM" "aM" "bM"
  shows
    "separation(##M,λx. xaM. xbM.
                    pair(##M,x,a,xa) & xa  r & pair(##M,x,b,xb) & xb  r &
                    (fxM. gxM. fun_apply(##M,f,x,fx) & fun_apply(##M,g,x,gx) &
                                     fx  gx))"
proof -
  obtain rffm where
    fmsats:"env. envlist(M) 
    (xaM. xbM. pair(##M,nth(0,env),nth(4,env),xa) & xa  nth(1,env) &
    pair(##M,nth(0,env),nth(5,env),xb) & xb  nth(1,env) & (fxM. gxM.
    fun_apply(##M,nth(2,env),nth(0,env),fx) & fun_apply(##M,nth(3,env),nth(0,env),gx) & fx  gx))
     sats(M,rffm(0,1,2,3,4,5),env)"
    and
    "rffm(0,1,2,3,4,5)  formula"
    and
    "arity(rffm(0,1,2,3,4,5)) = 6"
    using recfun_fm_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "a1M. a2M. a3M. a4M. a5M.
        separation(##M, λx. sats(M,rffm(0,1,2,3,4,5) , [x,a1,a2,a3,a4,a5]))"
    using separation_ax by simp
  moreover
  have "(xaM. xbM. pair(##M,x,a4,xa) & xa  a1 & pair(##M,x,a5,xb) & xb  a1 &
          (fxM. gxM. fun_apply(##M,a2,x,fx) & fun_apply(##M,a3,x,gx) & fx  gx))
           sats(M,rffm(0,1,2,3,4,5) , [x,a1,a2,a3,a4,a5])"
    if "xM" "a1M" "a2M" "a3M" "a4M" "a5M"  for x a1 a2 a3 a4 a5
    using that fmsats[of "[x,a1,a2,a3,a4,a5]"] by simp
  ultimately
  have "a1M. a2M. a3M. a4M. a5M. separation(##M, λ x .
          xaM. xbM. pair(##M,x,a4,xa) & xa  a1 & pair(##M,x,a5,xb) & xb  a1 &
          (fxM. gxM. fun_apply(##M,a2,x,fx) & fun_apply(##M,a3,x,gx) & fx  gx))"
    unfolding separation_def by simp
  with rM fM gM aM bM show ?thesis by simp
qed


(* Instance of Replacement for M_basic *)

schematic_goal funsp_fm_auto:
  assumes
    "nth(i,env) = p" "nth(j,env) = z" "nth(h,env) = n"
    "i  nat" "j  nat" "h  nat" "env  list(A)"
  shows
    "(fA. bA. nbA. cnbfA. pair(##A,f,b,p) & pair(##A,n,b,nb) & is_cons(##A,nb,f,cnbf) &
    upair(##A,cnbf,cnbf,z))  sats(A,?fsfm(i,j,h),env)"
  by (insert assms ; (rule sep_rules | simp)+)


lemma funspace_succ_rep_intf :
  assumes
    "nM"
  shows
    "strong_replacement(##M,
          λp z. fM. bM. nbM. cnbfM.
                pair(##M,f,b,p) & pair(##M,n,b,nb) & is_cons(##M,nb,f,cnbf) &
                upair(##M,cnbf,cnbf,z))"
proof -
  obtain fsfm where
    fmsats:"envlist(M) 
    (fM. bM. nbM. cnbfM. pair(##M,f,b,nth(0,env)) & pair(##M,nth(2,env),b,nb)
      & is_cons(##M,nb,f,cnbf) & upair(##M,cnbf,cnbf,nth(1,env)))
     sats(M,fsfm(0,1,2),env)"
    and "fsfm(0,1,2)  formula" and "arity(fsfm(0,1,2)) = 3" for env
    using funsp_fm_auto[of concl:M] by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "n0M. strong_replacement(##M, λp z. sats(M,fsfm(0,1,2) , [p,z,n0]))"
    using replacement_ax by simp
  moreover
  have "(fM. bM. nbM. cnbfM. pair(##M,f,b,p) & pair(##M,n0,b,nb) &
          is_cons(##M,nb,f,cnbf) & upair(##M,cnbf,cnbf,z))
           sats(M,fsfm(0,1,2) , [p,z,n0])"
    if "pM" "zM" "n0M" for p z n0
    using that fmsats[of "[p,z,n0]"] by simp
  ultimately
  have "n0M. strong_replacement(##M, λ p z.
          fM. bM. nbM. cnbfM. pair(##M,f,b,p) & pair(##M,n0,b,nb) &
          is_cons(##M,nb,f,cnbf) & upair(##M,cnbf,cnbf,z))"
    unfolding strong_replacement_def univalent_def by simp
  with nM show ?thesis by simp
qed


(* Interface with M_basic *)

lemmas M_basic_sep_instances =
  inter_sep_intf diff_sep_intf cartprod_sep_intf
  image_sep_intf converse_sep_intf restrict_sep_intf
  pred_sep_intf memrel_sep_intf comp_sep_intf is_recfun_sep_intf

lemma mbasic : "M_basic(##M)"
  using trans_M zero_in_M power_ax M_basic_sep_instances funspace_succ_rep_intf mtriv
  by unfold_locales auto

end

sublocale M_ZF_trans  M_basic "##M"
  by (rule mbasic)

subsection‹Interface with term‹M_trancl›

(* rtran_closure_mem *)
schematic_goal rtran_closure_mem_auto:
  assumes
    "nth(i,env) = p" "nth(j,env) = r"  "nth(k,env) = B"
    "i  nat" "j  nat" "k  nat" "env  list(A)"
  shows
    "rtran_closure_mem(##A,B,r,p)  sats(A,?rcfm(i,j,k),env)"
  unfolding rtran_closure_mem_def
  by (insert assms ; (rule sep_rules | simp)+)


lemma (in M_ZF_trans) rtrancl_separation_intf:
  assumes
    "rM"
    and
    "AM"
  shows
    "separation (##M, rtran_closure_mem(##M,A,r))"
proof -
  obtain rcfm where
    fmsats:"env. envlist(M) 
    (rtran_closure_mem(##M,nth(2,env),nth(1,env),nth(0,env)))  sats(M,rcfm(0,1,2),env)"
    and
    "rcfm(0,1,2)  formula"
    and
    "arity(rcfm(0,1,2)) = 3"
    using rtran_closure_mem_auto by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "xM. aM. separation(##M, λy. sats(M,rcfm(0,1,2) , [y,x,a]))"
    using separation_ax by simp
  moreover
  have "(rtran_closure_mem(##M,a,x,y))
           sats(M,rcfm(0,1,2) , [y,x,a])"
    if "yM" "xM" "aM" for y x a
    using that fmsats[of "[y,x,a]"] by simp
  ultimately
  have "xM. aM. separation(##M, rtran_closure_mem(##M,a,x))"
    unfolding separation_def by simp
  with rM AM show ?thesis by simp
qed

schematic_goal rtran_closure_fm_auto:
  assumes
    "nth(i,env) = r" "nth(j,env) = rp"
    "i  nat" "j  nat" "env  list(A)"
  shows
    "rtran_closure(##A,r,rp)  sats(A,?rtc(i,j),env)"
  unfolding rtran_closure_def
  by (insert assms ; (rule sep_rules rtran_closure_mem_auto | simp)+)

schematic_goal trans_closure_fm_auto:
  assumes
    "nth(i,env) = r" "nth(j,env) = rp"
    "i  nat" "j  nat" "env  list(A)"
  shows
    "tran_closure(##A,r,rp)  sats(A,?tc(i,j),env)"
  unfolding tran_closure_def
  by (insert assms ; (rule sep_rules rtran_closure_fm_auto | simp))+

synthesize "trans_closure_fm" from_schematic trans_closure_fm_auto

schematic_goal wellfounded_trancl_fm_auto:
  assumes
    "nth(i,env) = p" "nth(j,env) = r"  "nth(k,env) = B"
    "i  nat" "j  nat" "k  nat" "env  list(A)"
  shows
    "wellfounded_trancl(##A,B,r,p)  sats(A,?wtf(i,j,k),env)"
  unfolding  wellfounded_trancl_def
  by (insert assms ; (rule sep_rules trans_closure_fm_iff_sats | simp)+)

lemma (in M_ZF_trans) wftrancl_separation_intf:
  assumes
    "rM"
    and
    "ZM"
  shows
    "separation (##M, wellfounded_trancl(##M,Z,r))"
proof -
  obtain rcfm where
    fmsats:"env. envlist(M) 
    (wellfounded_trancl(##M,nth(2,env),nth(1,env),nth(0,env)))  sats(M,rcfm(0,1,2),env)"
    and
    "rcfm(0,1,2)  formula"
    and
    "arity(rcfm(0,1,2)) = 3"
    using wellfounded_trancl_fm_auto[of concl:M "nth(2,_)"] unfolding fm_defs trans_closure_fm_def
    by (simp del:FOL_sats_iff pair_abs add: fm_defs nat_simp_union)
  then
  have "xM. zM. separation(##M, λy. sats(M,rcfm(0,1,2) , [y,x,z]))"
    using separation_ax by simp
  moreover
  have "(wellfounded_trancl(##M,z,x,y))
           sats(M,rcfm(0,1,2) , [y,x,z])"
    if "yM" "xM" "zM" for y x z
    using that fmsats[of "[y,x,z]"] by simp
  ultimately
  have "xM. zM. separation(##M, wellfounded_trancl(##M,z,x))"
    unfolding separation_def by simp
  with rM ZM show ?thesis by simp
qed

(* nat ∈ M *)

lemma (in M_ZF_trans) finite_sep_intf:
  "separation(##M, λx. xnat)"
proof -
  have "arity(finite_ordinal_fm(0)) = 1 "
    unfolding finite_ordinal_fm_def limit_ordinal_fm_def empty_fm_def succ_fm_def cons_fm_def
      union_fm_def upair_fm_def
    by (simp add: nat_union_abs1 Un_commute)
  with separation_ax
  have "(vM. separation(##M,λx. sats(M,finite_ordinal_fm(0),[x,v])))"
    by simp
  then have "(vM. separation(##M,finite_ordinal(##M)))"
    unfolding separation_def by simp
  then have "separation(##M,finite_ordinal(##M))"
    using zero_in_M by auto
  then show ?thesis unfolding separation_def by simp
qed


lemma (in M_ZF_trans) nat_subset_I' :
  " IM ; 0I ; x. xI  succ(x)I   nat  I"
  by (rule subsetI,induct_tac x,simp+)


lemma (in M_ZF_trans) nat_subset_I :
  "IM. nat  I"
proof -
  have "IM. 0I  (xM. xI  succ(x)I)"
    using infinity_ax unfolding infinity_ax_def by auto
  then obtain I where
    "IM" "0I" "(xM. xI  succ(x)I)"
    by auto
  then have "x. xI  succ(x)I"
    using Transset_intf[OF trans_M]  by simp
  then have "natI"
    using  IM 0I nat_subset_I' by simp
  then show ?thesis using IM by auto
qed

lemma (in M_ZF_trans) nat_in_M :
  "nat  M"
proof -
  have 1:"{xB . xA}=A" if "AB" for A B
    using that by auto
  obtain I where
    "IM" "natI"
    using nat_subset_I by auto
  then have "{xI . xnat}  M"
    using finite_sep_intf separation_closed[of "λx . xnat"] by simp
  then show ?thesis
    using ‹natI 1 by simp
qed
  (* end nat ∈ M *)


lemma (in M_ZF_trans) mtrancl : "M_trancl(##M)"
  using  mbasic rtrancl_separation_intf wftrancl_separation_intf nat_in_M
    wellfounded_trancl_def
  by unfold_locales auto

sublocale M_ZF_trans  M_trancl "##M"
  by (rule mtrancl)

subsection‹Interface with term‹M_eclose›

lemma repl_sats:
  assumes
    sat:"x z. xM  zM  sats(M,φ,Cons(x,Cons(z,env)))  P(x,z)"
  shows
    "strong_replacement(##M,λx z. sats(M,φ,Cons(x,Cons(z,env)))) 
   strong_replacement(##M,P)"
  by (rule strong_replacement_cong,simp add:sat)

lemma (in M_ZF_trans) nat_trans_M :
  "nM" if "nnat" for n
  using that nat_in_M Transset_intf[OF trans_M] by simp

lemma (in M_ZF_trans) list_repl1_intf:
  assumes
    "AM"
  shows
    "iterates_replacement(##M, is_list_functor(##M,A), 0)"
proof -
  {
    fix n
    assume "nnat"
    have "succ(n)M"
      using nnat› nat_trans_M by simp
    then have 1:"Memrel(succ(n))M"
      using nnat› Memrel_closed by simp
    have "0M"
      using  nat_0I nat_trans_M by simp
    then have "is_list_functor(##M, A, a, b)
        sats(M, list_functor_fm(13,1,0), [b,a,c,d,a0,a1,a2,a3,a4,y,x,z,Memrel(succ(n)),A,0])"
      if "aM" "bM" "cM" "dM" "a0M" "a1M" "a2M" "a3M" "a4M" "yM" "xM" "zM"
      for a b c d a0 a1 a2 a3 a4 y x z
      using that 1 AM list_functor_iff_sats by simp
    then have "sats(M, iterates_MH_fm(list_functor_fm(13,1,0),10,2,1,0), [a0,a1,a2,a3,a4,y,x,z,Memrel(succ(n)),A,0])
         iterates_MH(##M,is_list_functor(##M,A),0,a2, a1, a0)"
      if "a0M" "a1M" "a2M" "a3M" "a4M" "yM" "xM" "zM"
      for a0 a1 a2 a3 a4 y x z
      using that sats_iterates_MH_fm[of M "is_list_functor(##M,A)" _] 1 0M AM  by simp
    then have 2:"sats(M, is_wfrec_fm(iterates_MH_fm(list_functor_fm(13,1,0),10,2,1,0),3,1,0),
                            [y,x,z,Memrel(succ(n)),A,0])
        
        is_wfrec(##M, iterates_MH(##M,is_list_functor(##M,A),0) , Memrel(succ(n)), x, y)"
      if "yM" "xM" "zM" for y x z
      using  that sats_is_wfrec_fm 1 0M AM by simp
    let
      ?f="Exists(And(pair_fm(1,0,2),
               is_wfrec_fm(iterates_MH_fm(list_functor_fm(13,1,0),10,2,1,0),3,1,0)))"
    have satsf:"sats(M, ?f, [x,z,Memrel(succ(n)),A,0])
        
        (yM. pair(##M,x,y,z) &
        is_wfrec(##M, iterates_MH(##M,is_list_functor(##M,A),0) , Memrel(succ(n)), x, y))"
      if "xM" "zM" for x z
      using that 2 1 0M AM by (simp del:pair_abs)
    have "arity(?f) = 5"
      unfolding iterates_MH_fm_def is_wfrec_fm_def is_recfun_fm_def is_nat_case_fm_def
        restriction_fm_def list_functor_fm_def number1_fm_def cartprod_fm_def
        sum_fm_def quasinat_fm_def pre_image_fm_def fm_defs
      by (simp add:nat_simp_union)
    then
    have "strong_replacement(##M,λx z. sats(M,?f,[x,z,Memrel(succ(n)),A,0]))"
      using replacement_ax 1 AM 0M by simp
    then
    have "strong_replacement(##M,λx z.
          yM. pair(##M,x,y,z) & is_wfrec(##M, iterates_MH(##M,is_list_functor(##M,A),0) ,
                Memrel(succ(n)), x, y))"
      using repl_sats[of M ?f "[Memrel(succ(n)),A,0]"]  satsf by (simp del:pair_abs)
  }
  then
  show ?thesis unfolding iterates_replacement_def wfrec_replacement_def by simp
qed



(* Iterates_replacement para predicados sin parámetros *)
lemma (in M_ZF_trans) iterates_repl_intf :
  assumes
    "vM" and
    isfm:"is_F_fm  formula" and
    arty:"arity(is_F_fm)=2" and
    satsf: "a b env'.  aM ; bM ; env'list(M) 
               is_F(a,b)  sats(M, is_F_fm, [b,a]@env')"
  shows
    "iterates_replacement(##M,is_F,v)"
proof -
  {
    fix n
    assume "nnat"
    have "succ(n)M"
      using nnat› nat_trans_M by simp
    then have 1:"Memrel(succ(n))M"
      using nnat› Memrel_closed by simp
    {
      fix a0 a1 a2 a3 a4 y x z
      assume as:"a0M" "a1M" "a2M" "a3M" "a4M" "yM" "xM" "zM"
      have "sats(M, is_F_fm, Cons(b,Cons(a,Cons(c,Cons(d,[a0,a1,a2,a3,a4,y,x,z,Memrel(succ(n)),v])))))
           is_F(a,b)"
        if "aM" "bM" "cM" "dM" for a b c d
        using as that 1 satsf[of a b "[c,d,a0,a1,a2,a3,a4,y,x,z,Memrel(succ(n)),v]"] vM by simp
      then
      have "sats(M, iterates_MH_fm(is_F_fm,9,2,1,0), [a0,a1,a2,a3,a4,y,x,z,Memrel(succ(n)),v])
           iterates_MH(##M,is_F,v,a2, a1, a0)"
        using as
          sats_iterates_MH_fm[of M "is_F" "is_F_fm"] 1 vM by simp
    }
    then have 2:"sats(M, is_wfrec_fm(iterates_MH_fm(is_F_fm,9,2,1,0),3,1,0),
                            [y,x,z,Memrel(succ(n)),v])
        
        is_wfrec(##M, iterates_MH(##M,is_F,v),Memrel(succ(n)), x, y)"
      if "yM" "xM" "zM" for y x z
      using  that sats_is_wfrec_fm 1 vM by simp
    let
      ?f="Exists(And(pair_fm(1,0,2),
               is_wfrec_fm(iterates_MH_fm(is_F_fm,9,2,1,0),3,1,0)))"
    have satsf:"sats(M, ?f, [x,z,Memrel(succ(n)),v])
        
        (yM. pair(##M,x,y,z) &
        is_wfrec(##M, iterates_MH(##M,is_F,v) , Memrel(succ(n)), x, y))"
      if "xM" "zM" for x z
      using that 2 1 vM by (simp del:pair_abs)
    have "arity(?f) = 4"
      unfolding iterates_MH_fm_def is_wfrec_fm_def is_recfun_fm_def is_nat_case_fm_def
        restriction_fm_def pre_image_fm_def quasinat_fm_def fm_defs
      using arty by (simp add:nat_simp_union)
    then
    have "strong_replacement(##M,λx z. sats(M,?f,[x,z,Memrel(succ(n)),v]))"
      using replacement_ax 1 vM is_F_fmformula› by simp
    then
    have "strong_replacement(##M,λx z.
          yM. pair(##M,x,y,z) & is_wfrec(##M, iterates_MH(##M,is_F,v) ,
                Memrel(succ(n)), x, y))"
      using repl_sats[of M ?f "[Memrel(succ(n)),v]"]  satsf by (simp del:pair_abs)
  }
  then
  show ?thesis unfolding iterates_replacement_def wfrec_replacement_def by simp
qed

lemma (in M_ZF_trans) formula_repl1_intf :
  "iterates_replacement(##M, is_formula_functor(##M), 0)"
proof -
  have "0M"
    using  nat_0I nat_trans_M by simp
  have 1:"arity(formula_functor_fm(1,0)) = 2"
    unfolding formula_functor_fm_def fm_defs sum_fm_def cartprod_fm_def number1_fm_def
    by (simp add:nat_simp_union)
  have 2:"formula_functor_fm(1,0)formula" by simp
  have "is_formula_functor(##M,a,b) 
        sats(M, formula_functor_fm(1,0), [b,a])"
    if "aM" "bM"  for a b
    using that by simp
  then show ?thesis using 0M 1 2 iterates_repl_intf by simp
qed

lemma (in M_ZF_trans) nth_repl_intf:
  assumes
    "l  M"
  shows
    "iterates_replacement(##M,λl' t. is_tl(##M,l',t),l)"
proof -
  have 1:"arity(tl_fm(1,0)) = 2"
    unfolding tl_fm_def fm_defs quasilist_fm_def Cons_fm_def Nil_fm_def Inr_fm_def number1_fm_def
      Inl_fm_def by (simp add:nat_simp_union)
  have 2:"tl_fm(1,0)formula" by simp
  have "is_tl(##M,a,b)  sats(M, tl_fm(1,0), [b,a])"
    if "aM" "bM" for a b
    using that by simp
  then show ?thesis using lM 1 2 iterates_repl_intf by simp
qed


lemma (in M_ZF_trans) eclose_repl1_intf:
  assumes
    "AM"
  shows
    "iterates_replacement(##M, big_union(##M), A)"
proof -
  have 1:"arity(big_union_fm(1,0)) = 2"
    unfolding big_union_fm_def fm_defs by (simp add:nat_simp_union)
  have 2:"big_union_fm(1,0)formula" by simp
  have "big_union(##M,a,b)  sats(M, big_union_fm(1,0), [b,a])"
    if "aM" "bM" for a b
    using that by simp
  then show ?thesis using AM 1 2 iterates_repl_intf by simp
qed

(*
    and list_replacement2:
   "M(A) ⟹ strong_replacement(M,
         λn y. n∈nat & is_iterates(M, is_list_functor(M,A), 0, n, y))"

*)
lemma (in M_ZF_trans) list_repl2_intf:
  assumes
    "AM"
  shows
    "strong_replacement(##M,λn y. nnat & is_iterates(##M, is_list_functor(##M,A), 0, n, y))"
proof -
  have "0M"
    using  nat_0I nat_trans_M by simp
  have "is_list_functor(##M,A,a,b) 
        sats(M,list_functor_fm(13,1,0),[b,a,c,d,e,f,g,h,i,j,k,n,y,A,0,nat])"
    if "aM" "bM" "cM" "dM" "eM" "fM""gM""hM""iM""jM" "kM" "nM" "yM"
    for a b c d e f g h i j k n y
    using that 0M nat_in_M AM by simp
  then
  have 1:"sats(M, is_iterates_fm(list_functor_fm(13,1,0),3,0,1),[n,y,A,0,nat] ) 
           is_iterates(##M, is_list_functor(##M,A), 0, n , y)"
    if "nM" "yM" for n y
    using that 0M AM nat_in_M
      sats_is_iterates_fm[of M "is_list_functor(##M,A)"] by simp
  let ?f = "And(Member(0,4),is_iterates_fm(list_functor_fm(13,1,0),3,0,1))"
  have satsf:"sats(M, ?f,[n,y,A,0,nat] ) 
        nnat & is_iterates(##M, is_list_functor(##M,A), 0, n, y)"
    if "nM" "yM" for n y
    using that 0M AM nat_in_M 1 by simp
  have "arity(?f) = 5"
    unfolding is_iterates_fm_def restriction_fm_def list_functor_fm_def number1_fm_def Memrel_fm_def
      cartprod_fm_def sum_fm_def quasinat_fm_def pre_image_fm_def fm_defs is_wfrec_fm_def
      is_recfun_fm_def iterates_MH_fm_def is_nat_case_fm_def
    by (simp add:nat_simp_union)
  then
  have "strong_replacement(##M,λn y. sats(M,?f,[n,y,A,0,nat]))"
    using replacement_ax 1 nat_in_M AM 0M by simp
  then
  show ?thesis using repl_sats[of M ?f "[A,0,nat]"]  satsf  by simp
qed

lemma (in M_ZF_trans) formula_repl2_intf:
  "strong_replacement(##M,λn y. nnat & is_iterates(##M, is_formula_functor(##M), 0, n, y))"
proof -
  have "0M"
    using  nat_0I nat_trans_M by simp
  have "is_formula_functor(##M,a,b) 
        sats(M,formula_functor_fm(1,0),[b,a,c,d,e,f,g,h,i,j,k,n,y,0,nat])"
    if "aM" "bM" "cM" "dM" "eM" "fM""gM""hM""iM""jM" "kM" "nM" "yM"
    for a b c d e f g h i j k n y
    using that 0M nat_in_M by simp
  then
  have 1:"sats(M, is_iterates_fm(formula_functor_fm(1,0),2,0,1),[n,y,0,nat] ) 
           is_iterates(##M, is_formula_functor(##M), 0, n , y)"
    if "nM" "yM" for n y
    using that 0M nat_in_M
      sats_is_iterates_fm[of M "is_formula_functor(##M)"] by simp
  let ?f = "And(Member(0,3),is_iterates_fm(formula_functor_fm(1,0),2,0,1))"
  have satsf:"sats(M, ?f,[n,y,0,nat] ) 
        nnat & is_iterates(##M, is_formula_functor(##M), 0, n, y)"
    if "nM" "yM" for n y
    using that 0M nat_in_M 1 by simp
  have artyf:"arity(?f) = 4"
    unfolding is_iterates_fm_def formula_functor_fm_def fm_defs sum_fm_def quasinat_fm_def
      cartprod_fm_def number1_fm_def Memrel_fm_def ordinal_fm_def transset_fm_def
      is_wfrec_fm_def is_recfun_fm_def iterates_MH_fm_def is_nat_case_fm_def subset_fm_def
      pre_image_fm_def restriction_fm_def
    by (simp add:nat_simp_union)
  then
  have "strong_replacement(##M,λn y. sats(M,?f,[n,y,0,nat]))"
    using replacement_ax 1 artyf 0M nat_in_M by simp
  then
  show ?thesis using repl_sats[of M ?f "[0,nat]"]  satsf  by simp
qed


(*
   "M(A) ⟹ strong_replacement(M,
         λn y. n∈nat & is_iterates(M, big_union(M), A, n, y))"
*)

lemma (in M_ZF_trans) eclose_repl2_intf:
  assumes
    "AM"
  shows
    "strong_replacement(##M,λn y. nnat & is_iterates(##M, big_union(##M), A, n, y))"
proof -
  have "big_union(##M,a,b) 
        sats(M,big_union_fm(1,0),[b,a,c,d,e,f,g,h,i,j,k,n,y,A,nat])"
    if "aM" "bM" "cM" "dM" "eM" "fM""gM""hM""iM""jM" "kM" "nM" "yM"
    for a b c d e f g h i j k n y
    using that AM nat_in_M by simp
  then
  have 1:"sats(M, is_iterates_fm(big_union_fm(1,0),2,0,1),[n,y,A,nat] ) 
           is_iterates(##M, big_union(##M), A, n , y)"
    if "nM" "yM" for n y
    using that AM nat_in_M
      sats_is_iterates_fm[of M "big_union(##M)"] by simp
  let ?f = "And(Member(0,3),is_iterates_fm(big_union_fm(1,0),2,0,1))"
  have satsf:"sats(M, ?f,[n,y,A,nat] ) 
        nnat & is_iterates(##M, big_union(##M), A, n, y)"
    if "nM" "yM" for n y
    using that AM nat_in_M 1 by simp
  have artyf:"arity(?f) = 4"
    unfolding is_iterates_fm_def formula_functor_fm_def fm_defs sum_fm_def quasinat_fm_def
      cartprod_fm_def number1_fm_def Memrel_fm_def ordinal_fm_def transset_fm_def
      is_wfrec_fm_def is_recfun_fm_def iterates_MH_fm_def is_nat_case_fm_def subset_fm_def
      pre_image_fm_def restriction_fm_def
    by (simp add:nat_simp_union)
  then
  have "strong_replacement(##M,λn y. sats(M,?f,[n,y,A,nat]))"
    using replacement_ax 1 artyf AM nat_in_M by simp
  then
  show ?thesis using repl_sats[of M ?f "[A,nat]"]  satsf  by simp
qed

lemma (in M_ZF_trans) mdatatypes : "M_datatypes(##M)"
  using  mtrancl list_repl1_intf list_repl2_intf formula_repl1_intf
    formula_repl2_intf nth_repl_intf
  by unfold_locales auto

sublocale M_ZF_trans  M_datatypes "##M"
  by (rule mdatatypes)

lemma (in M_ZF_trans) meclose : "M_eclose(##M)"
  using mdatatypes eclose_repl1_intf eclose_repl2_intf
  by unfold_locales auto

sublocale M_ZF_trans  M_eclose "##M"
  by (rule meclose)

(* Interface with locale M_eclose_pow *)

(* "powerset(M,A,z) ≡ ∀x[M]. x ∈ z ⟷ subset(M,x,A)" *)
definition
  powerset_fm :: "[i,i]  i" where
  "powerset_fm(A,z)  Forall(Iff(Member(0,succ(z)),subset_fm(0,succ(A))))"

lemma powerset_type [TC]:
  " x  nat; y  nat   powerset_fm(x,y)  formula"
  by (simp add:powerset_fm_def)

definition
  is_powapply_fm :: "[i,i,i]  i" where
  "is_powapply_fm(f,y,z) 
      Exists(And(fun_apply_fm(succ(f), succ(y), 0),
            Forall(Iff(Member(0, succ(succ(z))),
            Forall(Implies(Member(0, 1), Member(0, 2)))))))"

lemma is_powapply_type [TC] :
  "fnat ; ynat; znat  is_powapply_fm(f,y,z)formula"
  unfolding is_powapply_fm_def by simp

lemma sats_is_powapply_fm :
  assumes
    "fnat" "ynat" "znat" "envlist(A)" "0A"
  shows
    "is_powapply(##A,nth(f, env),nth(y, env),nth(z, env))
     sats(A,is_powapply_fm(f,y,z),env)"
  unfolding is_powapply_def is_powapply_fm_def is_Collect_def powerset_def subset_def
  using nth_closed assms by simp


lemma (in M_ZF_trans) powapply_repl :
  assumes
    "fM"
  shows
    "strong_replacement(##M,is_powapply(##M,f))"
proof -
  have "arity(is_powapply_fm(2,0,1)) = 3"
    unfolding is_powapply_fm_def
    by (simp add: fm_defs nat_simp_union)
  then
  have "f0M. strong_replacement(##M, λp z. sats(M,is_powapply_fm(2,0,1) , [p,z,f0]))"
    using replacement_ax by simp
  moreover
  have "is_powapply(##M,f0,p,z)  sats(M,is_powapply_fm(2,0,1) , [p,z,f0])"
    if "pM" "zM" "f0M" for p z f0
    using that zero_in_M sats_is_powapply_fm[of 2 0 1 "[p,z,f0]" M] by simp
  ultimately
  have "f0M. strong_replacement(##M, is_powapply(##M,f0))"
    unfolding strong_replacement_def univalent_def by simp
  with fM show ?thesis by simp
qed


(*"PHrank(M,f,y,z) ≡ M(z) ∧ (∃fy[M]. fun_apply(M,f,y,fy) ∧ successor(M,fy,z))"*)
definition
  PHrank_fm :: "[i,i,i]  i" where
  "PHrank_fm(f,y,z)  Exists(And(fun_apply_fm(succ(f),succ(y),0)
                                 ,succ_fm(0,succ(z))))"

lemma PHrank_type [TC]:
  " x  nat; y  nat; z  nat   PHrank_fm(x,y,z)  formula"
  by (simp add:PHrank_fm_def)


lemma (in M_ZF_trans) sats_PHrank_fm [simp]:
  " x  nat; y  nat; z  nat;  env  list(M)  
     sats(M,PHrank_fm(x,y,z),env) 
        PHrank(##M,nth(x,env),nth(y,env),nth(z,env))"
  using zero_in_M Internalizations.nth_closed by (simp add: PHrank_def PHrank_fm_def)


lemma (in M_ZF_trans) phrank_repl :
  assumes
    "fM"
  shows
    "strong_replacement(##M,PHrank(##M,f))"
proof -
  have "arity(PHrank_fm(2,0,1)) = 3"
    unfolding PHrank_fm_def
    by (simp add: fm_defs nat_simp_union)
  then
  have "f0M. strong_replacement(##M, λp z. sats(M,PHrank_fm(2,0,1) , [p,z,f0]))"
    using replacement_ax by simp
  then
  have "f0M. strong_replacement(##M, PHrank(##M,f0))"
    unfolding strong_replacement_def univalent_def by simp
  with fM show ?thesis by simp
qed


(*"is_Hrank(M,x,f,hc) ≡ (∃R[M]. big_union(M,R,hc) ∧is_Replace(M,x,PHrank(M,f),R)) "*)
definition
  is_Hrank_fm :: "[i,i,i]  i" where
  "is_Hrank_fm(x,f,hc)  Exists(And(big_union_fm(0,succ(hc)),
                                Replace_fm(succ(x),PHrank_fm(succ(succ(succ(f))),0,1),0)))"

lemma is_Hrank_type [TC]:
  " x  nat; y  nat; z  nat   is_Hrank_fm(x,y,z)  formula"
  by (simp add:is_Hrank_fm_def)

lemma (in M_ZF_trans) sats_is_Hrank_fm [simp]:
  " x  nat; y  nat; z  nat; env  list(M)
     sats(M,is_Hrank_fm(x,y,z),env) 
        is_Hrank(##M,nth(x,env),nth(y,env),nth(z,env))"
  using zero_in_M is_Hrank_def is_Hrank_fm_def sats_Replace_fm
  by simp

(* M(x) ⟹ wfrec_replacement(M,is_Hrank(M),rrank(x)) *)
lemma (in M_ZF_trans) wfrec_rank :
  assumes
    "XM"
  shows
    "wfrec_replacement(##M,is_Hrank(##M),rrank(X))"
proof -
  have
    "is_Hrank(##M,a2, a1, a0) 
             sats(M, is_Hrank_fm(2,1,0), [a0,a1,a2,a3,a4,y,x,z,rrank(X)])"
    if "a4M" "a3M" "a2M" "a1M" "a0M" "yM" "xM" "zM" for a4 a3 a2 a1 a0 y x z
    using that rrank_in_M XM by simp
  then
  have
    1:"sats(M, is_wfrec_fm(is_Hrank_fm(2,1,0),3,1,0),[y,x,z,rrank(X)])
   is_wfrec(##M, is_Hrank(##M) ,rrank(X), x, y)"
    if "yM" "xM" "zM" for y x z
    using that XM rrank_in_M sats_is_wfrec_fm by simp
  let
    ?f="Exists(And(pair_fm(1,0,2),is_wfrec_fm(is_Hrank_fm(2,1,0),3,1,0)))"
  have satsf:"sats(M, ?f, [x,z,rrank(X)])
               (yM. pair(##M,x,y,z) & is_wfrec(##M, is_Hrank(##M) , rrank(X), x, y))"
    if "xM" "zM" for x z
    using that 1 XM rrank_in_M by (simp del:pair_abs)
  have "arity(?f) = 3"
    unfolding is_wfrec_fm_def is_recfun_fm_def is_nat_case_fm_def is_Hrank_fm_def PHrank_fm_def
      restriction_fm_def list_functor_fm_def number1_fm_def cartprod_fm_def
      sum_fm_def quasinat_fm_def pre_image_fm_def fm_defs
    by (simp add:nat_simp_union)
  then
  have "strong_replacement(##M,λx z. sats(M,?f,[x,z,rrank(X)]))"
    using replacement_ax 1 XM rrank_in_M by simp
  then
  have "strong_replacement(##M,λx z.
          yM. pair(##M,x,y,z) & is_wfrec(##M, is_Hrank(##M) , rrank(X), x, y))"
    using repl_sats[of M ?f "[rrank(X)]"]  satsf by (simp del:pair_abs)
  then
  show ?thesis unfolding wfrec_replacement_def  by simp
qed

(*"is_HVfrom(M,A,x,f,h) ≡ ∃U[M]. ∃R[M].  union(M,A,U,h)
        ∧ big_union(M,R,U) ∧ is_Replace(M,x,is_powapply(M,f),R)"*)
definition
  is_HVfrom_fm :: "[i,i,i,i]  i" where
  "is_HVfrom_fm(A,x,f,h)  Exists(Exists(And(union_fm(A #+ 2,1,h #+ 2),
                            And(big_union_fm(0,1),
                            Replace_fm(x #+ 2,is_powapply_fm(f #+ 4,0,1),0)))))"

lemma is_HVfrom_type [TC]:
  " Anat; x  nat; f  nat; h  nat   is_HVfrom_fm(A,x,f,h)  formula"
  by (simp add:is_HVfrom_fm_def)

lemma sats_is_HVfrom_fm :
  " anat; x  nat; f  nat; h  nat; env  list(A); 0A
     sats(A,is_HVfrom_fm(a,x,f,h),env) 
        is_HVfrom(##A,nth(a,env),nth(x,env),nth(f,env),nth(h,env))"
  using is_HVfrom_def is_HVfrom_fm_def sats_Replace_fm[OF sats_is_powapply_fm]
  by simp

lemma is_HVfrom_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(x,env) = xx" "nth(f,env) = ff" "nth(h,env) = hh"
    "anat" "xnat" "fnat" "hnat" "envlist(A)" "0A"
  shows
    "is_HVfrom(##A,aa,xx,ff,hh)  sats(A, is_HVfrom_fm(a,x,f,h), env)"
  using assms sats_is_HVfrom_fm by simp

(* FIX US *)
schematic_goal sats_is_Vset_fm_auto:
  assumes
    "inat" "vnat" "envlist(A)" "0A"
    "i < length(env)" "v < length(env)"
  shows
    "is_Vset(##A,nth(i, env),nth(v, env))
     sats(A,?ivs_fm(i,v),env)"
  unfolding is_Vset_def is_Vfrom_def
  by (insert assms; (rule sep_rules is_HVfrom_iff_sats is_transrec_iff_sats | simp)+)

schematic_goal is_Vset_iff_sats:
  assumes
    "nth(i,env) = ii" "nth(v,env) = vv"
    "inat" "vnat" "envlist(A)" "0A"
    "i < length(env)" "v < length(env)"
  shows
    "is_Vset(##A,ii,vv)  sats(A, ?ivs_fm(i,v), env)"
  unfolding ‹nth(i,env) = ii[symmetric] ‹nth(v,env) = vv[symmetric]
  by (rule sats_is_Vset_fm_auto(1); simp add:assms)


lemma (in M_ZF_trans) memrel_eclose_sing :
  "aM  saM. esaM. mesaM.
       upair(##M,a,a,sa) & is_eclose(##M,sa,esa) & membership(##M,esa,mesa)"
  using upair_ax eclose_closed Memrel_closed unfolding upair_ax_def
  by (simp del:upair_abs)


lemma (in M_ZF_trans) trans_repl_HVFrom :
  assumes
    "AM" "iM"
  shows
    "transrec_replacement(##M,is_HVfrom(##M,A),i)"
proof -
  { fix mesa
    assume "mesaM"
    have
      0:"is_HVfrom(##M,A,a2, a1, a0) 
      sats(M, is_HVfrom_fm(8,2,1,0), [a0,a1,a2,a3,a4,y,x,z,A,mesa])"
      if "a4M" "a3M" "a2M" "a1M" "a0M" "yM" "xM" "zM" for a4 a3 a2 a1 a0 y x z
      using that zero_in_M sats_is_HVfrom_fm mesaM AM by simp
    have
      1:"sats(M, is_wfrec_fm(is_HVfrom_fm(8,2,1,0),4,1,0),[y,x,z,A,mesa])
         is_wfrec(##M, is_HVfrom(##M,A),mesa, x, y)"
      if "yM" "xM" "zM" for y x z
      using that AM mesaM sats_is_wfrec_fm[OF 0] by simp
    let
      ?f="Exists(And(pair_fm(1,0,2),is_wfrec_fm(is_HVfrom_fm(8,2,1,0),4,1,0)))"
    have satsf:"sats(M, ?f, [x,z,A,mesa])
               (yM. pair(##M,x,y,z) & is_wfrec(##M, is_HVfrom(##M,A) , mesa, x, y))"
      if "xM" "zM" for x z
      using that 1 AM mesaM by (simp del:pair_abs)
    have "arity(?f) = 4"
      unfolding is_HVfrom_fm_def is_wfrec_fm_def is_recfun_fm_def is_nat_case_fm_def
        restriction_fm_def list_functor_fm_def number1_fm_def cartprod_fm_def
        is_powapply_fm_def sum_fm_def quasinat_fm_def pre_image_fm_def fm_defs
      by (simp add:nat_simp_union)
    then
    have "strong_replacement(##M,λx z. sats(M,?f,[x,z,A,mesa]))"
      using replacement_ax 1 AM mesaM by simp
    then
    have "strong_replacement(##M,λx z.
          yM. pair(##M,x,y,z) & is_wfrec(##M, is_HVfrom(##M,A) , mesa, x, y))"
      using repl_sats[of M ?f "[A,mesa]"]  satsf by (simp del:pair_abs)
    then
    have "wfrec_replacement(##M,is_HVfrom(##M,A),mesa)"
      unfolding wfrec_replacement_def  by simp
  }
  then show ?thesis unfolding transrec_replacement_def
    using iM memrel_eclose_sing by simp
qed


lemma (in M_ZF_trans) meclose_pow : "M_eclose_pow(##M)"
  using meclose power_ax powapply_repl phrank_repl trans_repl_HVFrom wfrec_rank
  by unfold_locales auto

sublocale M_ZF_trans  M_eclose_pow "##M"
  by (rule meclose_pow)

lemma (in M_ZF_trans) repl_gen :
  assumes
    f_abs: "x y.  xM; yM   is_F(##M,x,y)  y = f(x)"
    and
    f_sats: "x y. xM ; yM  
             sats(M,f_fm,Cons(x,Cons(y,env)))  is_F(##M,x,y)"
    and
    f_form: "f_fm  formula"
    and
    f_arty: "arity(f_fm) = 2"
    and
    "envlist(M)"
  shows
    "strong_replacement(##M, λx y. y = f(x))"
proof -
  have "sats(M,f_fm,[x,y]@env)  is_F(##M,x,y)" if "xM" "yM" for x y
    using that f_sats[of x y] by simp
  moreover
  from f_form f_arty
  have "strong_replacement(##M, λx y. sats(M,f_fm,[x,y]@env))"
    using envlist(M) replacement_ax by simp
  ultimately
  have "strong_replacement(##M, is_F(##M))"
    using strong_replacement_cong[of "##M" "λx y. sats(M,f_fm,[x,y]@env)" "is_F(##M)"] by simp
  with f_abs show ?thesis
    using strong_replacement_cong[of "##M" "is_F(##M)" "λx y. y = f(x)"] by simp
qed

(* Proof Scheme for instances of separation *)
lemma (in M_ZF_trans) sep_in_M :
  assumes
    "φ  formula" "envlist(M)"
    "arity(φ)  1 #+ length(env)" "AM" and
    satsQ: "x. xM  sats(M,φ,[x]@env)  Q(x)"
  shows
    "{yA . Q(y)}M"
proof -
  have "separation(##M,λx. sats(M,φ,[x] @ env))"
    using assms separation_ax by simp
  then show ?thesis using
      AM satsQ trans_M
      separation_cong[of "##M" "λy. sats(M,φ,[y]@env)" "Q"]
      separation_closed  by simp
qed

end

Theory Forcing_Data

section‹Transitive set models of ZF›
text‹This theory defines the locale termM_ZF_trans for
transitive models of ZF, and the associated termforcing_data
 that adds a forcing notion›
theory Forcing_Data
  imports  
    Forcing_Notions 
    Interface

begin

lemma Transset_M :
  "Transset(M)   yx  x  M  y  M"
  by (simp add: Transset_def,auto)  


locale M_ZF = 
  fixes M 
  assumes 
    upair_ax:         "upair_ax(##M)"
    and Union_ax:         "Union_ax(##M)"
    and power_ax:         "power_ax(##M)"
    and extensionality:   "extensionality(##M)"
    and foundation_ax:    "foundation_ax(##M)"
    and infinity_ax:      "infinity_ax(##M)"
    and separation_ax:    "φformula  envlist(M)  arity(φ)  1 #+ length(env) 
                    separation(##M,λx. sats(M,φ,[x] @ env))" 
    and replacement_ax:   "φformula  envlist(M)  arity(φ)  2 #+ length(env)  
                    strong_replacement(##M,λx y. sats(M,φ,[x,y] @ env))" 

locale M_ctm = M_ZF +
  fixes enum
  assumes M_countable:      "enumbij(nat,M)"
    and trans_M:          "Transset(M)"

begin
interpretation intf: M_ZF_trans "M"
  using M_ZF_trans.intro
    trans_M upair_ax Union_ax power_ax extensionality
    foundation_ax infinity_ax separation_ax[simplified] 
    replacement_ax[simplified]
  by simp


lemmas transitivity = Transset_intf[OF trans_M]

lemma zero_in_M:  "0  M" 
  by (rule intf.zero_in_M)

lemma tuples_in_M: "AM  BM  A,BM" 
  by (simp flip:setclass_iff)

lemma nat_in_M : "nat  M"
  by (rule intf.nat_in_M)

lemma n_in_M : "nnat  nM"
  using nat_in_M transitivity by simp

lemma mtriv: "M_trivial(##M)" 
  by (rule intf.mtriv)

lemma mtrans: "M_trans(##M)"
  by (rule intf.mtrans)

lemma mbasic: "M_basic(##M)"
  by (rule intf.mbasic)

lemma mtrancl: "M_trancl(##M)"
  by (rule intf.mtrancl)

lemma mdatatypes: "M_datatypes(##M)"
  by (rule intf.mdatatypes)

lemma meclose: "M_eclose(##M)"
  by (rule intf.meclose)

lemma meclose_pow: "M_eclose_pow(##M)"
  by (rule intf.meclose_pow)



end (* M_ctm *)

(* M_ctm interface *)
sublocale M_ctm  M_trivial "##M"
  by  (rule mtriv)

sublocale M_ctm  M_trans "##M"
  by  (rule mtrans)

sublocale M_ctm  M_basic "##M"
  by  (rule mbasic)

sublocale M_ctm  M_trancl "##M"
  by  (rule mtrancl)

sublocale M_ctm  M_datatypes "##M"
  by  (rule mdatatypes)

sublocale M_ctm  M_eclose "##M"
  by  (rule meclose)

sublocale M_ctm  M_eclose_pow "##M"
  by  (rule meclose_pow)

(* end interface *)

context M_ctm
begin

subsectiontermCollects in $M$›
lemma Collect_in_M_0p :
  assumes
    Qfm : "Q_fm  formula" and
    Qarty : "arity(Q_fm) = 1" and
    Qsats : "x. xM  sats(M,Q_fm,[x])  is_Q(##M,x)" and
    Qabs  : "x. xM  is_Q(##M,x)  Q(x)" and
    "AM"
  shows
    "Collect(A,Q)M" 
proof -
  have "zA  zM" for z
    using AM transitivity[of z A] by simp
  then
  have 1:"Collect(A,is_Q(##M)) = Collect(A,Q)" 
    using Qabs Collect_cong[of "A" "A" "is_Q(##M)" "Q"] by simp
  have "separation(##M,is_Q(##M))"
    using separation_ax Qsats Qarty Qfm
      separation_cong[of "##M" "λy. sats(M,Q_fm,[y])" "is_Q(##M)"]
    by simp
  then 
  have "Collect(A,is_Q(##M))M"
    using separation_closed AM by simp 
  then
  show ?thesis using 1 by simp
qed

lemma Collect_in_M_2p :
  assumes
    Qfm : "Q_fm  formula" and
    Qarty : "arity(Q_fm) = 3" and
    params_M : "yM" "zM" and
    Qsats : "x. xM  sats(M,Q_fm,[x,y,z])  is_Q(##M,x,y,z)" and
    Qabs  : "x. xM  is_Q(##M,x,y,z)  Q(x,y,z)" and
    "AM"
  shows
    "Collect(A,λx. Q(x,y,z))M" 
proof -
  have "zA  zM" for z
    using AM transitivity[of z A] by simp
  then
  have 1:"Collect(A,λx. is_Q(##M,x,y,z)) = Collect(A,λx. Q(x,y,z))" 
    using Qabs Collect_cong[of "A" "A" "λx. is_Q(##M,x,y,z)" "λx. Q(x,y,z)"] by simp
  have "separation(##M,λx. is_Q(##M,x,y,z))"
    using separation_ax Qsats Qarty Qfm params_M
      separation_cong[of "##M" "λx. sats(M,Q_fm,[x,y,z])" "λx. is_Q(##M,x,y,z)"]
    by simp
  then 
  have "Collect(A,λx. is_Q(##M,x,y,z))M"
    using separation_closed AM by simp 
  then
  show ?thesis using 1 by simp
qed

lemma Collect_in_M_4p :
  assumes
    Qfm : "Q_fm  formula" and
    Qarty : "arity(Q_fm) = 5" and
    params_M : "a1M" "a2M" "a3M" "a4M" and
    Qsats : "x. xM  sats(M,Q_fm,[x,a1,a2,a3,a4])  is_Q(##M,x,a1,a2,a3,a4)" and
    Qabs  : "x. xM  is_Q(##M,x,a1,a2,a3,a4)  Q(x,a1,a2,a3,a4)" and
    "AM"
  shows
    "Collect(A,λx. Q(x,a1,a2,a3,a4))M" 
proof -
  have "zA  zM" for z
    using AM transitivity[of z A] by simp
  then
  have 1:"Collect(A,λx. is_Q(##M,x,a1,a2,a3,a4)) = Collect(A,λx. Q(x,a1,a2,a3,a4))" 
    using Qabs Collect_cong[of "A" "A" "λx. is_Q(##M,x,a1,a2,a3,a4)" "λx. Q(x,a1,a2,a3,a4)"] 
    by simp
  have "separation(##M,λx. is_Q(##M,x,a1,a2,a3,a4))"
    using separation_ax Qsats Qarty Qfm params_M
      separation_cong[of "##M" "λx. sats(M,Q_fm,[x,a1,a2,a3,a4])" 
        "λx. is_Q(##M,x,a1,a2,a3,a4)"]
    by simp
  then 
  have "Collect(A,λx. is_Q(##M,x,a1,a2,a3,a4))M"
    using separation_closed AM by simp 
  then
  show ?thesis using 1 by simp
qed

lemma Repl_in_M :
  assumes
    f_fm:  "f_fm  formula" and
    f_ar:  "arity(f_fm) 2 #+ length(env)" and
    fsats: "x y. xM  yM  sats(M,f_fm,[x,y]@env)  is_f(x,y)" and
    fabs:  "x y. xM  yM  is_f(x,y)  y = f(x)" and
    fclosed: "x. xA  f(x)  M"  and
    "AM" "envlist(M)" 
  shows "{f(x). xA}M"
proof -
  have "strong_replacement(##M, λx y. sats(M,f_fm,[x,y]@env))"
    using replacement_ax f_fm f_ar envlist(M) by simp
  then
  have "strong_replacement(##M, λx y. y = f(x))"
    using fsats fabs 
      strong_replacement_cong[of "##M" "λx y. sats(M,f_fm,[x,y]@env)" "λx y. y = f(x)"]
    by simp
  then
  have "{ y . xA , y = f(x) }  M" 
    using AM fclosed strong_replacement_closed by simp
  moreover
  have "{f(x). xA} = { y . xA , y = f(x) }"
    by auto
  ultimately show ?thesis by simp
qed

end (* M_ctm *)      

subsection‹A forcing locale and generic filters›
locale forcing_data = forcing_notion + M_ctm +
  assumes P_in_M:           "P  M"
    and leq_in_M:         "leq  M"

begin

lemma transD : "Transset(M)  y  M  y  M" 
  by (unfold Transset_def, blast) 

(* P ⊆ M *)
lemmas P_sub_M = transD[OF trans_M P_in_M]

definition
  M_generic :: "io" where
  "M_generic(G)  filter(G)  (DM. DP  dense(D)DG0)"

lemma M_genericD [dest]: "M_generic(G)  xG  xP"
  unfolding M_generic_def by (blast dest:filterD)

lemma M_generic_leqD [dest]: "M_generic(G)  pG  qP  pq  qG"
  unfolding M_generic_def by (blast dest:filter_leqD)

lemma M_generic_compatD [dest]: "M_generic(G)  pG  rG  qG. qp  qr"
  unfolding M_generic_def by (blast dest:low_bound_filter)

lemma M_generic_denseD [dest]: "M_generic(G)  dense(D)  DP  DM  qG. qD"
  unfolding M_generic_def by blast

lemma G_nonempty: "M_generic(G)  G0"
proof -
  have "PP" ..
  assume
    "M_generic(G)"
  with P_in_M P_dense PP show
    "G  0"
    unfolding M_generic_def by auto
qed

lemma one_in_G : 
  assumes "M_generic(G)"
  shows  "one  G" 
proof -
  from assms have "GP" 
    unfolding M_generic_def and filter_def by simp
  from ‹M_generic(G) have "increasing(G)" 
    unfolding M_generic_def and filter_def by simp
  with GP and ‹M_generic(G) 
  show ?thesis 
    using G_nonempty and one_in_P and one_max 
    unfolding increasing_def by blast
qed

lemma G_subset_M: "M_generic(G)  G  M"
  using transitivity[OF _ P_in_M] by auto

declare iff_trans [trans]

lemma generic_filter_existence: 
  "pP  G. pG  M_generic(G)"
proof -
  assume "pP"
  let ?D="λnnat. (if (enum`nP  dense(enum`n))  then enum`n else P)"
  have "nnat. ?D`n  Pow(P)"
    by auto
  then 
  have "?D:natPow(P)"
    using lam_type by auto
  have Eq4: "nnat. dense(?D`n)"
  proof(intro ballI)
    fix n
    assume "nnat"
    then
    have "dense(?D`n)  dense(if enum`n  P  dense(enum`n) then enum`n else P)"
      by simp
    also 
    have "...   (¬(enum`n  P  dense(enum`n))  dense(P)) "
      using split_if by simp
    finally
    show "dense(?D`n)"
      using P_dense nnat› by auto
  qed
  from ?D_ and Eq4 
  interpret cg: countable_generic P leq one ?D 
    by (unfold_locales, auto)
  from pP 
  obtain G where Eq6: "pG  filter(G)  (nnat.(?D`n)G0)"
    using cg.countable_rasiowa_sikorski[where M="λ_. M"]  P_sub_M
      M_countable[THEN bij_is_fun] M_countable[THEN bij_is_surj, THEN surj_range] 
    unfolding cg.D_generic_def by blast
  then 
  have Eq7: "(DM. DP  dense(D)DG0)"
  proof (intro ballI impI)
    fix D
    assume "DM" and Eq9: "D  P  dense(D) " 
    have "yM. xnat. enum`x= y"
      using M_countable and  bij_is_surj unfolding surj_def by (simp)
    with DM obtain n where Eq10: "nnat  enum`n = D" 
      by auto
    with Eq9 and if_P
    have "?D`n = D" by (simp)
    with Eq6 and Eq10 
    show "DG0" by auto
  qed
  with Eq6 
  show ?thesis unfolding M_generic_def by auto
qed

(* Compatibility lemmas *)
lemma compat_in_abs :
  assumes
    "AM" "rM" "pM" "qM" 
  shows
    "is_compat_in(##M,A,r,p,q)  compat_in(A,r,p,q)" 
proof -
  have "dA  dM" for d
    using transitivity AM by simp
  moreover from this
  have "dA  d, t  M" if "tM" for t d
    using that pair_in_M_iff by simp
  ultimately 
  show ?thesis
    unfolding is_compat_in_def compat_in_def 
    using assms pair_in_M_iff transitivity by auto
qed

definition
  compat_in_fm :: "[i,i,i,i]  i" where
  "compat_in_fm(A,r,p,q)  
    Exists(And(Member(0,succ(A)),Exists(And(pair_fm(1,p#+2,0),
                                        And(Member(0,r#+2),
                                 Exists(And(pair_fm(2,q#+3,0),Member(0,r#+3))))))))" 

lemma compat_in_fm_type[TC] : 
  " Anat;rnat;pnat;qnat  compat_in_fm(A,r,p,q)formula" 
  unfolding compat_in_fm_def by simp

lemma sats_compat_in_fm:
  assumes
    "Anat" "rnat"  "pnat" "qnat" "envlist(M)"  
  shows
    "sats(M,compat_in_fm(A,r,p,q),env)  
            is_compat_in(##M,nth(A, env),nth(r, env),nth(p, env),nth(q, env))"
  unfolding compat_in_fm_def is_compat_in_def using assms by simp

end (* forcing_data *)

end

Theory Internal_ZFC_Axioms

section‹The ZFC axioms, internalized›
theory Internal_ZFC_Axioms
  imports 
  Forcing_Data

begin

schematic_goal ZF_union_auto:
    "Union_ax(##A)  (A, []  ?zfunion)"
  unfolding Union_ax_def 
  by ((rule sep_rules | simp)+)

synthesize "ZF_union_fm" from_schematic ZF_union_auto

schematic_goal ZF_power_auto:
    "power_ax(##A)  (A, []  ?zfpow)"
  unfolding power_ax_def powerset_def subset_def
  by ((rule sep_rules | simp)+)

synthesize "ZF_power_fm" from_schematic ZF_power_auto

schematic_goal ZF_pairing_auto:
    "upair_ax(##A)  (A, []  ?zfpair)"
  unfolding upair_ax_def 
  by ((rule sep_rules | simp)+)

synthesize "ZF_pairing_fm" from_schematic ZF_pairing_auto

schematic_goal ZF_foundation_auto:
    "foundation_ax(##A)  (A, []  ?zfpow)"
  unfolding foundation_ax_def 
  by ((rule sep_rules | simp)+)

synthesize "ZF_foundation_fm" from_schematic ZF_foundation_auto

schematic_goal ZF_extensionality_auto:
    "extensionality(##A)  (A, []  ?zfpow)"
  unfolding extensionality_def 
  by ((rule sep_rules | simp)+)

synthesize "ZF_extensionality_fm" from_schematic ZF_extensionality_auto

schematic_goal ZF_infinity_auto:
    "infinity_ax(##A)  (A, []  ((i,j,h)))"
  unfolding infinity_ax_def 
  by ((rule sep_rules | simp)+)

synthesize "ZF_infinity_fm" from_schematic ZF_infinity_auto

schematic_goal ZF_choice_auto:
    "choice_ax(##A)  (A, []  ((i,j,h)))"
  unfolding choice_ax_def 
  by ((rule sep_rules | simp)+)

synthesize "ZF_choice_fm" from_schematic ZF_choice_auto

syntax
  "_choice" :: "i"  ("AC")
translations
  "AC"  "CONST ZF_choice_fm"

lemmas ZFC_fm_defs = ZF_extensionality_fm_def ZF_foundation_fm_def ZF_pairing_fm_def
              ZF_union_fm_def ZF_infinity_fm_def ZF_power_fm_def ZF_choice_fm_def

lemmas ZFC_fm_sats = ZF_extensionality_auto ZF_foundation_auto ZF_pairing_auto
              ZF_union_auto ZF_infinity_auto ZF_power_auto ZF_choice_auto

definition
  ZF_fin :: "i" where
  "ZF_fin  { ZF_extensionality_fm, ZF_foundation_fm, ZF_pairing_fm,
              ZF_union_fm, ZF_infinity_fm, ZF_power_fm }"

definition
  ZFC_fin :: "i" where
  "ZFC_fin  ZF_fin  {ZF_choice_fm}"

lemma ZFC_fin_type : "ZFC_fin  formula"
  unfolding ZFC_fin_def ZF_fin_def ZFC_fm_defs by (auto)

subsection‹The Axiom of Separation, internalized›
lemma iterates_Forall_type [TC]:
      " n  nat; p  formula   Forall^n(p)  formula"
  by (induct set:nat, auto)

lemma last_init_eq :
  assumes "l  list(A)" "length(l) = succ(n)"
  shows " aA. l'list(A). l = l'@[a]"
proof-
  from l_ ‹length(_) = _
  have "rev(l)  list(A)" "length(rev(l)) = succ(n)"
    by simp_all
  then
  obtain a l' where "aA" "l'list(A)" "rev(l) = Cons(a,l')"
    by (cases;simp)
  then
  have "l = rev(l') @ [a]" "rev(l')  list(A)"
    using rev_rev_ident[OF l_] by auto
  with a_
  show ?thesis by blast
qed

lemma take_drop_eq :
  assumes "llist(M)"
  shows " n . n < succ(length(l))  l = take(n,l) @ drop(n,l)"
  using llist(M)
proof induct
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then show ?case
  proof -
    {
      fix i
      assume "i<succ(succ(length(l)))"
      with llist(M)
      consider (lt) "i = 0" | (eq) "knat. i = succ(k)  k < succ(length(l))"
        using llist(M)  le_natI nat_imp_quasinat
        by (cases rule:nat_cases[of i];auto)
      then
      have "take(i,Cons(a,l)) @ drop(i,Cons(a,l)) = Cons(a,l)"
        using Cons
        by (cases;auto)
    }
    then show ?thesis using Cons by auto
  qed
qed

lemma list_split :
assumes "n  succ(length(rest))" "rest  list(M)"
shows  "relist(M). stlist(M). rest = re @ st  length(re) = pred(n)"
proof -
  from assms
  have "pred(n)  length(rest)"
    using pred_mono[OF _ n_] pred_succ_eq by auto
  with rest_
  have "pred(n)nat" "rest = take(pred(n),rest) @ drop(pred(n),rest)" (is "_ = ?re @ ?st")
    using take_drop_eq[OF rest_] le_natI by auto
  then
  have "length(?re) = pred(n)" "?relist(M)" "?stlist(M)"
    using length_take[rule_format,OF _ ‹pred(n)_] ‹pred(n)  _ rest_
    unfolding min_def
    by auto
  then
  show ?thesis
    using rev_bexI[of _ _ "λ re. stlist(M). rest = re @ st  length(re) = pred(n)"]
      ‹length(?re) = _ rest = _
    by auto
qed

lemma sats_nForall:
  assumes
    "φ  formula"
  shows
    "nnat  ms  list(M) 
       M, ms  (Forall^n(φ)) 
       (rest  list(M). length(rest) = n  M, rest @ ms  φ)"
proof (induct n arbitrary:ms set:nat)
  case 0
  with assms
  show ?case by simp
next
  case (succ n)
  have "(restlist(M). length(rest) = succ(n)  P(rest,n)) 
        (tM. reslist(M). length(res) = n  P(res @ [t],n))"
    if "nnat" for n P
    using that last_init_eq by force
  from this[of _ "λrest _. (M, rest @ ms  φ)"] nnat›
  have "(restlist(M). length(rest) = succ(n)  M, rest @ ms  φ) 
        (tM. reslist(M). length(res) = n   M, (res @ [t]) @ ms  φ)"
    by simp
    with assms succ(1,3) succ(2)[of "Cons(_,ms)"]
  show ?case
    using arity_sats_iff[of φ _ M "Cons(_, ms @ _)"] app_assoc
    by (simp)
qed

definition
  sep_body_fm :: "i  i" where
  "sep_body_fm(p)  Forall(Exists(Forall(
                           Iff(Member(0,1),And(Member(0,2),
                                    incr_bv1^2(p))))))"

lemma sep_body_fm_type [TC]: "p  formula  sep_body_fm(p)  formula"
  by (simp add: sep_body_fm_def)

lemma sats_sep_body_fm: 
  assumes
    "φ  formula" "mslist(M)" "restlist(M)"
  shows
    "M, rest @ ms  sep_body_fm(φ)  
     separation(##M,λx. M, [x] @ rest @ ms  φ)"
  using assms formula_add_params1[of _ 2 _ _ "[_,_]" ]
  unfolding sep_body_fm_def separation_def by simp

definition
  ZF_separation_fm :: "i  i" where
  "ZF_separation_fm(p)  Forall^(pred(arity(p)))(sep_body_fm(p))"

lemma ZF_separation_fm_type [TC]: "p  formula  ZF_separation_fm(p)  formula"
  by (simp add: ZF_separation_fm_def)

lemma sats_ZF_separation_fm_iff:
  assumes
    "φformula"
  shows
  "(M, []  (ZF_separation_fm(φ)))
   
   (envlist(M). arity(φ)  1 #+ length(env)  
      separation(##M,λx. M, [x] @ env  φ))"
proof (intro iffI ballI impI)
  let ?n="Arith.pred(arity(φ))"
  fix env
  assume "M, []  ZF_separation_fm(φ)" 
  assume "arity(φ)  1 #+ length(env)" "envlist(M)"
  moreover from this
  have "arity(φ)  succ(length(env))" by simp
  then
  obtain some rest where "somelist(M)" "restlist(M)" 
    "env = some @ rest" "length(some) = Arith.pred(arity(φ))"
    using list_split[OF ‹arity(φ)  succ(_) env_] by force
  moreover from φ_
  have "arity(φ)  succ(Arith.pred(arity(φ)))"
   using succpred_leI by simp
  moreover
  note assms
  moreover 
  assume "M, []  ZF_separation_fm(φ)" 
  moreover from calculation
  have "M, some  sep_body_fm(φ)"
    using sats_nForall[of "sep_body_fm(φ)" ?n]
    unfolding ZF_separation_fm_def by simp
  ultimately
  show "separation(##M, λx. M, [x] @ env  φ)"
    unfolding ZF_separation_fm_def
    using sats_sep_body_fm[of φ "[]" M some]
      arity_sats_iff[of φ rest M "[_] @ some"]
      separation_cong[of "##M" "λx. M, Cons(x, some @ rest)  φ" _ ]
    by simp
next ― ‹almost equal to the previous implication›
  let ?n="Arith.pred(arity(φ))"
  assume asm:"envlist(M). arity(φ)  1 #+ length(env)  
    separation(##M, λx. M, [x] @ env  φ)"
  {
    fix some
    assume "somelist(M)" "length(some) = Arith.pred(arity(φ))"
    moreover
    note φ_
    moreover from calculation
    have "arity(φ)  1 #+ length(some)" 
      using le_trans[OF succpred_leI] succpred_leI by simp
    moreover from calculation and asm
    have "separation(##M, λx. M, [x] @ some  φ)" by blast
    ultimately
    have "M, some  sep_body_fm(φ)" 
    using sats_sep_body_fm[of φ "[]" M some]
      arity_sats_iff[of φ _ M "[_,_] @ some"]
      strong_replacement_cong[of "##M" "λx y. M, Cons(x, Cons(y, some @ _))  φ" _ ]
    by simp
  }
  with φ_
  show "M, []  ZF_separation_fm(φ)"
    using sats_nForall[of "sep_body_fm(φ)" ?n]
    unfolding ZF_separation_fm_def
    by simp
qed

subsection‹The Axiom of Replacement, internalized›
schematic_goal sats_univalent_fm_auto:
  assumes 
    (*    Q_iff_sats:"⋀a b z env aa bb. nth(a,Cons(z,env)) = aa ⟹ nth(b,Cons(z,env)) = bb ⟹ z∈A 
          ⟹ aa ∈ A ⟹ bb ∈ A ⟹ env∈ list(A) ⟹ 
                 Q(aa,bb) ⟷ (A, Cons(z,env) ⊨ (Q_fm(a,b)))" ― ‹using only one formula› *)
    Q_iff_sats:"x y z. x  A  y  A  zA  
                 Q(x,z)  (A,Cons(z,Cons(y,Cons(x,env)))  Q1_fm)"
       "x y z. x  A  y  A  zA  
                 Q(x,y)  (A,Cons(z,Cons(y,Cons(x,env)))  Q2_fm)"
    and 
    asms: "nth(i,env) = B" "i  nat" "env  list(A)"
  shows
    "univalent(##A,B,Q)  A,env  ?ufm(i)"
  unfolding univalent_def 
  by (insert asms; (rule sep_rules Q_iff_sats | simp)+)
  
synthesize_notc "univalent_fm" from_schematic sats_univalent_fm_auto

lemma univalent_fm_type [TC]: "q1 formula  q2formula  inat  
  univalent_fm(q2,q1,i) formula"
  by (simp add:univalent_fm_def)

lemma sats_univalent_fm :
  assumes
    Q_iff_sats:"x y z. x  A  y  A  zA  
                 Q(x,z)  (A,Cons(z,Cons(y,Cons(x,env)))  Q1_fm)"
       "x y z. x  A  y  A  zA  
                 Q(x,y)  (A,Cons(z,Cons(y,Cons(x,env)))  Q2_fm)"
    and 
    asms: "nth(i,env) = B" "i  nat" "env  list(A)"
  shows
    "A,env  univalent_fm(Q1_fm,Q2_fm,i)  univalent(##A,B,Q)"
  unfolding univalent_fm_def using asms sats_univalent_fm_auto[OF Q_iff_sats] by simp

definition
  swap_vars :: "ii" where
  "swap_vars(φ)  
      Exists(Exists(And(Equal(0,3),And(Equal(1,2),iterates(λp. incr_bv(p)`2 , 2, φ)))))" 

lemma swap_vars_type[TC] :
  "φformula  swap_vars(φ) formula" 
  unfolding swap_vars_def by simp

lemma sats_swap_vars :
  "[x,y] @ env  list(M)  φformula  
    M, [x,y] @ env  swap_vars(φ) M,[y,x] @ env  φ"
  unfolding swap_vars_def
  using sats_incr_bv_iff [of _ _ M _ "[y,x]"] by simp

definition
  univalent_Q1 :: "i  i" where
  "univalent_Q1(φ)  incr_bv1(swap_vars(φ))"

definition
  univalent_Q2 :: "i  i" where
  "univalent_Q2(φ)  incr_bv(swap_vars(φ))`0"

lemma univalent_Qs_type [TC]: 
  assumes "φformula"
  shows "univalent_Q1(φ)  formula" "univalent_Q2(φ)  formula"
  unfolding univalent_Q1_def univalent_Q2_def using assms by simp_all

lemma sats_univalent_fm_assm:
  assumes 
    "x  A" "y  A" "zA" "env list(A)" "φ  formula"
  shows 
    "(A, ([x,z] @ env)  φ)  (A, Cons(z,Cons(y,Cons(x,env)))  (univalent_Q1(φ)))"
    "(A, ([x,y] @ env)  φ)  (A, Cons(z,Cons(y,Cons(x,env)))  (univalent_Q2(φ)))"
  unfolding univalent_Q1_def univalent_Q2_def
  using 
    sats_incr_bv_iff[of _ _ A _ "[]"] ― ‹simplifies iterates of termλx. incr_bv(x)`0
    sats_incr_bv1_iff[of _ "Cons(x,env)" A z y] 
    sats_swap_vars  assms 
   by simp_all

definition
  rep_body_fm :: "i  i" where
  "rep_body_fm(p)  Forall(Implies(
        univalent_fm(univalent_Q1(incr_bv(p)`2),univalent_Q2(incr_bv(p)`2),0),
        Exists(Forall(
          Iff(Member(0,1),Exists(And(Member(0,3),incr_bv(incr_bv(p)`2)`2)))))))"

lemma rep_body_fm_type [TC]: "p  formula  rep_body_fm(p)  formula"
  by (simp add: rep_body_fm_def)

lemmas ZF_replacement_simps = formula_add_params1[of φ 2 _ M "[_,_]" ]
  sats_incr_bv_iff[of _ _ M _ "[]"] ― ‹simplifies iterates of termλx. incr_bv(x)`0
  sats_incr_bv_iff[of _ _ M _ "[_,_]"]― ‹simplifies termλx. incr_bv(x)`2
  sats_incr_bv1_iff[of _ _ M] sats_swap_vars for φ M

lemma sats_rep_body_fm:
  assumes
    "φ  formula" "mslist(M)" "restlist(M)"
  shows
    "M, rest @ ms  rep_body_fm(φ)  
     strong_replacement(##M,λx y. M, [x,y] @ rest @ ms  φ)"
  using assms ZF_replacement_simps 
  unfolding rep_body_fm_def strong_replacement_def univalent_def
  unfolding univalent_fm_def univalent_Q1_def univalent_Q2_def
  by simp

definition
  ZF_replacement_fm :: "i  i" where
  "ZF_replacement_fm(p)  Forall^(pred(pred(arity(p))))(rep_body_fm(p))"

lemma ZF_replacement_fm_type [TC]: "p  formula  ZF_replacement_fm(p)  formula"
  by (simp add: ZF_replacement_fm_def)

lemma sats_ZF_replacement_fm_iff:
  assumes
    "φformula"
  shows
  "(M, []  (ZF_replacement_fm(φ)))
   
   (envlist(M). arity(φ)  2 #+ length(env)  
      strong_replacement(##M,λx y. M,[x,y] @ env  φ))"
proof (intro iffI ballI impI)
  let ?n="Arith.pred(Arith.pred(arity(φ)))"
  fix env
  assume "M, []  ZF_replacement_fm(φ)" "arity(φ)  2 #+ length(env)" "envlist(M)"
  moreover from this
  have "arity(φ)  succ(succ(length(env)))" by (simp)
  moreover from calculation 
  have "pred(arity(φ))  succ(length(env))"
    using pred_mono[OF _ ‹arity(φ)succ(_)] pred_succ_eq by simp
  moreover from calculation
  obtain some rest where "somelist(M)" "restlist(M)" 
    "env = some @ rest" "length(some) = Arith.pred(Arith.pred(arity(φ)))" 
    using list_split[OF ‹pred(_)  _ env_] by auto
  moreover
  note φ_
  moreover from this
  have "arity(φ)  succ(succ(Arith.pred(Arith.pred(arity(φ)))))"
    using le_trans[OF succpred_leI] succpred_leI by simp
  moreover from calculation
  have "M, some  rep_body_fm(φ)"
    using sats_nForall[of "rep_body_fm(φ)" ?n]
    unfolding ZF_replacement_fm_def
    by simp
  ultimately
  show "strong_replacement(##M, λx y. M, [x, y] @ env  φ)"
    using sats_rep_body_fm[of φ "[]" M some]
      arity_sats_iff[of φ rest M "[_,_] @ some"]
      strong_replacement_cong[of "##M" "λx y. M, Cons(x, Cons(y, some @ rest))  φ" _ ]
    by simp
next ― ‹almost equal to the previous implication›
  let ?n="Arith.pred(Arith.pred(arity(φ)))"
  assume asm:"envlist(M). arity(φ)  2 #+ length(env)  
    strong_replacement(##M, λx y. M, [x, y] @ env  φ)"
  {
    fix some
    assume "somelist(M)" "length(some) = Arith.pred(Arith.pred(arity(φ)))"
    moreover
    note φ_
    moreover from calculation
    have "arity(φ)  2 #+ length(some)" 
      using le_trans[OF succpred_leI] succpred_leI by simp
    moreover from calculation and asm
    have "strong_replacement(##M, λx y. M, [x, y] @ some  φ)" by blast
    ultimately
    have "M, some  rep_body_fm(φ)" 
    using sats_rep_body_fm[of φ "[]" M some]
      arity_sats_iff[of φ _ M "[_,_] @ some"]
      strong_replacement_cong[of "##M" "λx y. M, Cons(x, Cons(y, some @ _))  φ" _ ]
    by simp
  }
  with φ_
  show "M, []  ZF_replacement_fm(φ)"
    using sats_nForall[of "rep_body_fm(φ)" ?n]
    unfolding ZF_replacement_fm_def
    by simp
qed

definition
  ZF_inf :: "i" where
  "ZF_inf  {ZF_separation_fm(p) . p  formula }  {ZF_replacement_fm(p) . p  formula }"
              
lemma Un_subset_formula: "Aformula  Bformula  AB  formula"
  by auto
  
lemma ZF_inf_subset_formula : "ZF_inf  formula"
  unfolding ZF_inf_def by auto
    
definition
  ZFC :: "i" where
  "ZFC  ZF_inf  ZFC_fin"

definition
  ZF :: "i" where
  "ZF  ZF_inf  ZF_fin"

definition 
  ZF_minus_P :: "i" where
  "ZF_minus_P  ZF - { ZF_power_fm }"

lemma ZFC_subset_formula: "ZFC  formula"
  by (simp add:ZFC_def Un_subset_formula ZF_inf_subset_formula ZFC_fin_type)
  
txt‹Satisfaction of a set of sentences›
definition
  satT :: "[i,i]  o"  ("_  _" [36,36] 60) where
  "A  Φ    φΦ. (A,[]  φ)"

lemma satTI [intro!]: 
  assumes "φ. φΦ  A,[]  φ"
  shows "A  Φ"
  using assms unfolding satT_def by simp

lemma satTD [dest] :"A  Φ   φΦ  A,[]  φ"
  unfolding satT_def by simp

lemma sats_ZFC_iff_sats_ZF_AC: 
  "(N  ZFC)  (N  ZF)  (N, []  AC)"
    unfolding ZFC_def ZFC_fin_def ZF_def by auto

lemma M_ZF_iff_M_satT: "M_ZF(M)  (M  ZF)"
proof
  assume "M  ZF"
  then
  have fin: "upair_ax(##M)" "Union_ax(##M)" "power_ax(##M)"
    "extensionality(##M)" "foundation_ax(##M)" "infinity_ax(##M)"
    unfolding ZF_def ZF_fin_def ZFC_fm_defs satT_def
    using ZFC_fm_sats[of M] by simp_all
  {
    fix φ env
    assume "φ  formula" "envlist(M)" 
    moreover from M  ZF›
    have "pformula. (M, []  (ZF_separation_fm(p)))" 
         "pformula. (M, []  (ZF_replacement_fm(p)))"
      unfolding ZF_def ZF_inf_def by auto
    moreover from calculation
    have "arity(φ)  succ(length(env))  separation(##M, λx. (M, Cons(x, env)  φ))"
      "arity(φ)  succ(succ(length(env)))  strong_replacement(##M,λx y. sats(M,φ,Cons(x,Cons(y, env))))"
      using sats_ZF_separation_fm_iff sats_ZF_replacement_fm_iff by simp_all  
  }
  with fin
  show "M_ZF(M)"
    unfolding M_ZF_def by simp
next
  assume ‹M_ZF(M)
  then
  have "M  ZF_fin" 
    unfolding M_ZF_def ZF_fin_def ZFC_fm_defs satT_def
    using ZFC_fm_sats[of M] by blast
  moreover from ‹M_ZF(M)
  have "pformula. (M, []  (ZF_separation_fm(p)))" 
       "pformula. (M, []  (ZF_replacement_fm(p)))"
    unfolding M_ZF_def using sats_ZF_separation_fm_iff 
      sats_ZF_replacement_fm_iff by simp_all
  ultimately
  show "M  ZF"
    unfolding ZF_def ZF_inf_def by blast
qed

end

Theory Renaming

section‹Renaming of variables in internalized formulas›

theory Renaming
  imports
    Nat_Miscellanea
    "ZF-Constructible.Formula"
begin

lemma app_nm :
  assumes "nnat" "mnat" "fnm" "x  nat"
  shows "f`x  nat"
proof(cases "xn")
  case True
  then show ?thesis using assms in_n_in_nat apply_type by simp
next
  case False
  then show ?thesis using assms apply_0 domain_of_fun by simp
qed

subsection‹Renaming of free variables›

definition
  union_fun :: "[i,i,i,i]  i" where
  "union_fun(f,g,m,p)  λj  m  p  . if jm then f`j else g`j"

lemma union_fun_type:
  assumes "f  m  n"
    "g  p  q"
  shows "union_fun(f,g,m,p)  m  p  n  q"
proof -
  let ?h="union_fun(f,g,m,p)"
  have
    D: "?h`x  n  q" if "x  m  p" for x
  proof (cases "x  m")
    case True
    then have
      "x  m  p" by simp
    with xm
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with f  m  n xm
    have "?h`x  n" by simp
    then show ?thesis ..
  next
    case False
    with x  m  p
    have "x  p"
      by auto
    with xm
    have "?h`x = g`x"
      unfolding union_fun_def using beta by simp
    with g  p  q xp
    have "?h`x  q" by simp
    then show ?thesis ..
  qed
  have A:"function(?h)" unfolding union_fun_def using function_lam by simp
  have " x (m  p) × (n  q)" if "x ?h" for x
    using that lamE[of x "m  p" _ "x  (m  p) × (n  q)"] D unfolding union_fun_def
    by auto
  then have B:"?h  (m  p) × (n  q)" ..
  have "m  p  domain(?h)"
    unfolding union_fun_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma union_fun_action :
  assumes
    "env  list(M)"
    "env'  list(M)"
    "length(env) = m  p"
    " i . i  m   nth(f`i,env') = nth(i,env)"
    " j . j  p  nth(g`j,env') = nth(j,env)"
  shows " i . i  m  p 
          nth(i,env) = nth(union_fun(f,g,m,p)`i,env')"
proof -
  let ?h = "union_fun(f,g,m,p)"
  have "nth(x, env) = nth(?h`x,env')" if "x  m  p" for x
    using that
  proof (cases "xm")
    case True
    with xm
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with assms xm
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  next
    case False
    with x  m  p
    have
      "x  p" "xm"  by auto
    then
    have "?h`x = g`x"
      unfolding union_fun_def beta by simp
    with assms xp
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  qed
  then show ?thesis by simp
qed


lemma id_fn_type :
  assumes "n  nat"
  shows "id(n)  n  n"
  unfolding id_def using nnat› by simp

lemma id_fn_action:
  assumes "n  nat" "envlist(M)"
  shows " j . j < n  nth(j,env) = nth(id(n)`j,env)"
proof -
  show "nth(j,env) = nth(id(n)`j,env)" if "j < n" for j using that nnat› ltD by simp
qed


definition
  sum :: "[i,i,i,i,i]  i" where
  "sum(f,g,m,n,p)  λj  m#+p  . if j<m then f`j else (g`(j#-m))#+n"

lemma sum_inl:
  assumes "m  nat" "nnat"
    "f  mn" "x  m"
  shows "sum(f,g,m,n,p)`x = f`x"
proof -
  from mnat›
  have "mm#+p"
    using add_le_self[of m] by simp
  with assms
  have "xm#+p"
    using ltI[of x m] lt_trans2[of x m "m#+p"] ltD by simp
  from assms
  have "x<m"
    using ltI by simp
  with xm#+p
  show ?thesis unfolding sum_def by simp
qed

lemma sum_inr:
  assumes "m  nat" "nnat" "pnat"
    "gpq" "m  x" "x < m#+p"
  shows "sum(f,g,m,n,p)`x = g`(x#-m)#+n"
proof -
  from assms
  have "xnat"
    using in_n_in_nat[of "m#+p"] ltD
    by simp
  with assms
  have "¬ x<m"
    using not_lt_iff_le[THEN iffD2] by simp
  from assms
  have "xm#+p"
    using ltD by simp
  with ¬ x<m
  show ?thesis unfolding sum_def by simp
qed


lemma sum_action :
  assumes "m  nat" "nnat" "pnat" "qnat"
    "f  mn" "gpq"
    "env  list(M)"
    "env'  list(M)"
    "env1  list(M)"
    "env2  list(M)"
    "length(env) = m"
    "length(env1) = p"
    "length(env') = n"
    " i . i < m  nth(i,env) = nth(f`i,env')"
    " j. j < p  nth(j,env1) = nth(g`j,env2)"
  shows " i . i < m#+p 
          nth(i,env@env1) = nth(sum(f,g,m,n,p)`i,env'@env2)"
proof -
  let ?h = "sum(f,g,m,n,p)"
  from mnat› nnat› qnat›
  have "mm#+p" "nn#+q" "qn#+q"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from pnat›
  have "p = (m#+p)#-m" using diff_add_inverse2 by simp
  have "nth(x, env @ env1) = nth(?h`x,env'@env2)" if "x<m#+p" for x
  proof (cases "x<m")
    case True
    then
    have 2: "?h`x= f`x" "xm" "f`x  n" "xnat"
      using assms sum_inl ltD apply_type[of f m _ x] in_n_in_nat by simp_all
    with x<m assms
    have "f`x < n" "f`x<length(env')"  "f`xnat"
      using ltI in_n_in_nat by simp_all
    with 2 x<m assms
    have "nth(x,env@env1) = nth(x,env)"
      using nth_append[OF envlist(M)] xnat› by simp
    also
    have
      "... = nth(f`x,env')"
      using 2 x<m assms by simp
    also
    have "... = nth(f`x,env'@env2)"
      using nth_append[OF env'list(M)] f`x<length(env') f`x nat› by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  next
    case False
    have "xnat"
      using that in_n_in_nat[of "m#+p" x] ltD pnat› mnat› by simp
    with ‹length(env) = m
    have "mx" "length(env)  x"
      using not_lt_iff_le mnat› ¬x<m by simp_all
    with ¬x<m ‹length(env) = m
    have 2 : "?h`x= g`(x#-m)#+n"  "¬ x <length(env)"
      unfolding sum_def
      using  sum_inr that beta ltD by simp_all
    from assms xnat› p=m#+p#-m
    have "x#-m < p"
      using diff_mono[OF _ _ _ x<m#+p mx] by simp
    then have "x#-mp" using ltD by simp
    with gpq
    have "g`(x#-m)  q"  by simp
    with qnat› ‹length(env') = n
    have "g`(x#-m) < q" "g`(x#-m)nat" using ltI in_n_in_nat by simp_all
    with qnat› nnat›
    have "(g`(x#-m))#+n <n#+q" "n  g`(x#-m)#+n" "¬ g`(x#-m)#+n < length(env')"
      using add_lt_mono1[of "g`(x#-m)" _ n,OF _ qnat›]
        add_le_self2[of n] ‹length(env') = n
      by simp_all
    from assms ¬ x < length(env) ‹length(env) = m
    have "nth(x,env @ env1) = nth(x#-m,env1)"
      using nth_append[OF envlist(M) xnat›] by simp
    also
    have "... = nth(g`(x#-m),env2)"
      using assms x#-m < p by simp
    also
    have "... = nth((g`(x#-m)#+n)#-length(env'),env2)"
      using  ‹length(env') = n
        diff_add_inverse2 g`(x#-m)nat›
      by simp
    also
    have "... = nth((g`(x#-m)#+n),env'@env2)"
      using  nth_append[OF env'list(M)] nnat› ¬ g`(x#-m)#+n < length(env')
      by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  qed
  then show ?thesis by simp
qed

lemma sum_type  :
  assumes "m  nat" "nnat" "pnat" "qnat"
    "f  mn" "gpq"
  shows "sum(f,g,m,n,p)  (m#+p)  (n#+q)"
proof -
  let ?h = "sum(f,g,m,n,p)"
  from mnat› nnat› qnat›
  have "mm#+p" "nn#+q" "qn#+q"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from pnat›
  have "p = (m#+p)#-m" using diff_add_inverse2 by simp
  {fix x
    assume 1: "xm#+p" "x<m"
    with 1 have "?h`x= f`x" "xm"
      using assms sum_inl ltD by simp_all
    with fmn
    have "?h`x  n" by simp
    with nnat› have "?h`x < n" using ltI by simp
    with nn#+q
    have "?h`x < n#+q" using lt_trans2 by simp
    then
    have "?h`x  n#+q"  using ltD by simp
  }
  then have 1:"?h`x  n#+q" if "xm#+p" "x<m" for x using that .
  {fix x
    assume 1: "xm#+p" "mx"
    then have "x<m#+p" "xnat" using ltI in_n_in_nat[of "m#+p"] ltD by simp_all
    with 1
    have 2 : "?h`x= g`(x#-m)#+n"
      using assms sum_inr ltD by simp_all
    from assms xnat› p=m#+p#-m
    have "x#-m < p" using diff_mono[OF _ _ _ x<m#+p mx] by simp
    then have "x#-mp" using ltD by simp
    with gpq
    have "g`(x#-m)  q"  by simp
    with qnat› have "g`(x#-m) < q" using ltI by simp
    with qnat›
    have "(g`(x#-m))#+n <n#+q" using add_lt_mono1[of "g`(x#-m)" _ n,OF _ qnat›] by simp
    with 2
    have "?h`x  n#+q"  using ltD by simp
  }
  then have 2:"?h`x  n#+q" if "xm#+p" "mx" for x using that .
  have
    D: "?h`x  n#+q" if "xm#+p" for x
    using that
  proof (cases "x<m")
    case True
    then show ?thesis using 1 that by simp
  next
    case False
    with mnat› have "mx" using not_lt_iff_le that in_n_in_nat[of "m#+p"] by simp
    then show ?thesis using 2 that by simp
  qed
  have A:"function(?h)" unfolding sum_def using function_lam by simp
  have " x (m #+ p) × (n #+ q)" if "x ?h" for x
    using that lamE[of x "m#+p" _ "x  (m #+ p) × (n #+ q)"] D unfolding sum_def
    by auto
  then have B:"?h  (m #+ p) × (n #+ q)" ..
  have "m #+ p  domain(?h)"
    unfolding sum_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma sum_type_id :
  assumes
    "f  length(env)length(env')"
    "env  list(M)"
    "env'  list(M)"
    "env1  list(M)"
  shows
    "sum(f,id(length(env1)),length(env),length(env'),length(env1)) 
        (length(env)#+length(env1))  (length(env')#+length(env1))"
  using assms length_type id_fn_type sum_type
  by simp

lemma sum_type_id_aux2 :
  assumes
    "f  mn"
    "m  nat" "n  nat"
    "env1  list(M)"
  shows
    "sum(f,id(length(env1)),m,n,length(env1)) 
        (m#+length(env1))  (n#+length(env1))"
  using assms id_fn_type sum_type
  by auto

lemma sum_action_id :
  assumes
    "env  list(M)"
    "env'  list(M)"
    "f  length(env)length(env')"
    "env1  list(M)"
    " i . i < length(env)  nth(i,env) = nth(f`i,env')"
  shows " i . i < length(env)#+length(env1) 
          nth(i,env@env1) = nth(sum(f,id(length(env1)),length(env),length(env'),length(env1))`i,env'@env1)"
proof -
  from assms
  have "length(env)nat" (is "?m  _") by simp
  from assms have "length(env')nat" (is "?n  _") by simp
  from assms have "length(env1)nat" (is "?p  _") by simp
  note lenv = id_fn_action[OF ?pnat› env1list(M)]
  note lenv_ty = id_fn_type[OF ?pnat›]
  {
    fix i
    assume "i < length(env)#+length(env1)"
    have "nth(i,env@env1) = nth(sum(f,id(length(env1)),?m,?n,?p)`i,env'@env1)"
      using sum_action[OF ?mnat› ?nnat› ?pnat› ?pnat› f?m?n
          lenv_ty envlist(M) env'list(M)
          env1list(M) env1list(M) _
          _ _  assms(5) lenv
          ] i<?m#+length(env1) by simp
  }
  then show " i . i < ?m#+length(env1) 
          nth(i,env@env1) = nth(sum(f,id(?p),?m,?n,?p)`i,env'@env1)" by simp
qed

lemma sum_action_id_aux :
  assumes
    "f  mn"
    "env  list(M)"
    "env'  list(M)"
    "env1  list(M)"
    "length(env) = m"
    "length(env') = n"
    "length(env1) = p"
    " i . i < m  nth(i,env) = nth(f`i,env')"
  shows " i . i < m#+length(env1) 
          nth(i,env@env1) = nth(sum(f,id(length(env1)),m,n,length(env1))`i,env'@env1)"
  using assms length_type id_fn_type sum_action_id
  by auto


definition
  sum_id :: "[i,i]  i" where
  "sum_id(m,f)  sum(λx1.x,f,1,1,m)"

lemma sum_id0 : "mnatsum_id(m,f)`0 = 0"
  by(unfold sum_id_def,subst sum_inl,auto)

lemma sum_idS : "pnat  qnat  fpq  x  p  sum_id(p,f)`(succ(x)) = succ(f`x)"
  by(subgoal_tac "xnat",unfold sum_id_def,subst sum_inr,
      simp_all add:ltI,simp_all add: app_nm in_n_in_nat)

lemma sum_id_tc_aux :
  "p  nat   q  nat  f  p  q  sum_id(p,f)  1#+p  1#+q"
  by (unfold sum_id_def,rule sum_type,simp_all)

lemma sum_id_tc :
  "n  nat  m  nat  f  n  m  sum_id(n,f)  succ(n)  succ(m)"
  by(rule ssubst[of  "succ(n)  succ(m)" "1#+n  1#+m"],
      simp,rule sum_id_tc_aux,simp_all)

subsection‹Renaming of formulas›

consts   ren :: "ii"
primrec
  "ren(Member(x,y)) =
      (λ n  nat . λ m  nat. λf  n  m. Member (f`x, f`y))"

"ren(Equal(x,y)) =
      (λ n  nat . λ m  nat. λf  n  m. Equal (f`x, f`y))"

"ren(Nand(p,q)) =
      (λ n  nat . λ m  nat. λf  n  m. Nand (ren(p)`n`m`f, ren(q)`n`m`f))"

"ren(Forall(p)) =
      (λ n  nat . λ m  nat. λf  n  m. Forall (ren(p)`succ(n)`succ(m)`sum_id(n,f)))"

lemma arity_meml : "l  nat  Member(x,y)  formula  arity(Member(x,y))  l  x  l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_memr : "l  nat  Member(x,y)  formula  arity(Member(x,y))  l  y  l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eql : "l  nat  Equal(x,y)  formula  arity(Equal(x,y))  l  x  l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eqr : "l  nat  Equal(x,y)  formula  arity(Equal(x,y))  l  y  l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma  nand_ar1 : "p  formula  qformula arity(p)  arity(Nand(p,q))"
  by (simp,rule Un_upper1_le,simp+)
lemma nand_ar2 : "p  formula  qformula arity(q)  arity(Nand(p,q))"
  by (simp,rule Un_upper2_le,simp+)

lemma nand_ar1D : "p  formula  qformula  arity(Nand(p,q))  n  arity(p)  n"
  by(auto simp add:  le_trans[OF Un_upper1_le[of "arity(p)" "arity(q)"]])
lemma nand_ar2D : "p  formula  qformula  arity(Nand(p,q))  n  arity(q)  n"
  by(auto simp add:  le_trans[OF Un_upper2_le[of "arity(p)" "arity(q)"]])


lemma ren_tc : "p  formula 
  ( n m f . n  nat  m  nat  f  nm   ren(p)`n`m`f  formula)"
  by (induct set:formula,auto simp add: app_nm sum_id_tc)


lemma arity_ren :
  fixes "p"
  assumes "p  formula"
  shows " n m f . n  nat  m  nat  f  nm  arity(p)  n  arity(ren(p)`n`m`f)m"
  using assms
proof (induct set:formula)
  case (Member x y)
  then have "f`x  m" "f`y  m"
    using Member assms by (simp add: arity_meml apply_funtype,simp add:arity_memr apply_funtype)
  then show ?case using Member by (simp add: Un_least_lt ltI)
next
  case (Equal x y)
  then have "f`x  m" "f`y  m"
    using Equal assms by (simp add: arity_eql apply_funtype,simp add:arity_eqr apply_funtype)
  then show ?case using Equal by (simp add: Un_least_lt ltI)
next
  case (Nand p q)
  then have "arity(p)arity(Nand(p,q))"
    "arity(q)arity(Nand(p,q))"
    by (subst  nand_ar1,simp,simp,simp,subst nand_ar2,simp+)
  then have "arity(p)n"
    and "arity(q)n" using Nand
    by (rule_tac j="arity(Nand(p,q))" in le_trans,simp,simp)+
  then have "arity(ren(p)`n`m`f)  m" and  "arity(ren(q)`n`m`f)  m"
    using Nand by auto
  then show ?case using Nand by (simp add:Un_least_lt)
next
  case (Forall p)
  from Forall have "succ(n)nat"  "succ(m)nat" by auto
  from Forall have 2: "sum_id(n,f)  succ(n)succ(m)" by (simp add:sum_id_tc)
  from Forall have 3:"arity(p)  succ(n)" by (rule_tac n="arity(p)" in natE,simp+)
  then have "arity(ren(p)`succ(n)`succ(m)`sum_id(n,f))succ(m)" using
      Forall ‹succ(n)nat› ‹succ(m)nat› 2 by force
  then show ?case using Forall 2 3 ren_tc arity_type pred_le by auto
qed

lemma arity_forallE : "p  formula  m  nat  arity(Forall(p))  m  arity(p)  succ(m)"
  by(rule_tac n="arity(p)" in natE,erule arity_type,simp+)

lemma env_coincidence_sum_id :
  assumes "m  nat" "n  nat"
    "ρ  list(A)" "ρ'  list(A)"
    "f  n  m"
    " i . i < n  nth(i,ρ) = nth(f`i,ρ')"
    "a  A" "j  succ(n)"
  shows "nth(j,Cons(a,ρ)) = nth(sum_id(n,f)`j,Cons(a,ρ'))"
proof -
  let ?g="sum_id(n,f)"
  have "succ(n)  nat" using nnat› by simp
  then have "j  nat" using jsucc(n) in_n_in_nat by blast
  then have "nth(j,Cons(a,ρ)) = nth(?g`j,Cons(a,ρ'))"
  proof (cases rule:natE[OF jnat›])
    case 1
    then show ?thesis using assms sum_id0 by simp
  next
    case (2 i)
    with jsucc(n) have "succ(i)succ(n)" by simp
    with nnat› have "i  n" using nat_succD assms by simp
    have "f`im" using fnm apply_type in by simp
    then have "f`i  nat" using in_n_in_nat mnat› by simp
    have "nth(succ(i),Cons(a,ρ)) = nth(i,ρ)" using inat› by simp
    also have "... = nth(f`i,ρ')" using assms in ltI by simp
    also have "... = nth(succ(f`i),Cons(a,ρ'))" using f`inat› by simp
    also have "... = nth(?g`succ(i),Cons(a,ρ'))"
      using assms sum_idS[OF nnat› mnat›  fnm i  n] cases by simp
    finally have "nth(succ(i),Cons(a,ρ)) = nth(?g`succ(i),Cons(a,ρ'))" .
    then show ?thesis using j=succ(i) by simp
  qed
  then show ?thesis .
qed

lemma sats_iff_sats_ren :
  fixes "φ"
  assumes "φ  formula"
  shows  "  n  nat ; m  nat ; ρ  list(M) ; ρ'  list(M) ; f  n  m ;
            arity(φ)  n ;
             i . i < n  nth(i,ρ) = nth(f`i,ρ')  
         sats(M,φ,ρ)  sats(M,ren(φ)`n`m`f,ρ')"
  using φ  formula›
proof(induct φ arbitrary:n m ρ ρ' f)
  case (Member x y)
  have "ren(Member(x,y))`n`m`f = Member(f`x,f`y)" using Member assms arity_type by force
  moreover
  have "x  n" using Member arity_meml by simp
  moreover 
  have "y  n" using Member arity_memr by simp
  ultimately
  show ?case using Member ltI by simp
next
  case (Equal x y)
  have "ren(Equal(x,y))`n`m`f = Equal(f`x,f`y)" using Equal assms arity_type by force
  moreover
  have "x  n" using Equal arity_eql by simp
  moreover
  have "y  n" using Equal arity_eqr by simp
  ultimately show ?case using Equal ltI by simp
next
  case (Nand p q)
  have "ren(Nand(p,q))`n`m`f = Nand(ren(p)`n`m`f,ren(q)`n`m`f)" using Nand by simp
  moreover
  have "arity(p)  n" using Nand nand_ar1D by simp
  moreover from this
  have "i  arity(p)  i  n" for i using subsetD[OF le_imp_subset[OF ‹arity(p)  n]] by simp
  moreover from this
  have "i  arity(p)  nth(i,ρ) = nth(f`i,ρ')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,p,ρ)  sats(M,ren(p)`n`m`f,ρ')" using ‹arity(p)n Nand by simp
  have "arity(q)  n" using Nand nand_ar2D by simp
  moreover from this
  have "i  arity(q)  i  n" for i using subsetD[OF le_imp_subset[OF ‹arity(q)  n]] by simp
  moreover from this
  have "i  arity(q)  nth(i,ρ) = nth(f`i,ρ')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,q,ρ)  sats(M,ren(q)`n`m`f,ρ')" using assms ‹arity(q)n Nand by simp
  ultimately
  show ?case using Nand by simp
next
  case (Forall p)
  have 0:"ren(Forall(p))`n`m`f = Forall(ren(p)`succ(n)`succ(m)`sum_id(n,f))"
    using Forall by simp
  have 1:"sum_id(n,f)  succ(n)  succ(m)" (is "?g  _") using sum_id_tc Forall by simp
  then have 2: "arity(p)  succ(n)"
    using Forall le_trans[of _ "succ(pred(arity(p)))"] succpred_leI by simp
  have "succ(n)nat" "succ(m)nat" using Forall by auto
  then have A:" j .j < succ(n)  nth(j, Cons(a, ρ)) = nth(?g`j, Cons(a, ρ'))" if "aM" for a
    using that env_coincidence_sum_id Forall ltD by force
  have
    "sats(M,p,Cons(a,ρ))  sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,ρ'))" if "aM" for a
  proof -
    have C:"Cons(a,ρ)  list(M)" "Cons(a,ρ')list(M)" using Forall that by auto
    have "sats(M,p,Cons(a,ρ))  sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,ρ'))"
      using Forall(2)[OF ‹succ(n)nat› ‹succ(m)nat› C(1) C(2) 1 2 A[OF aM]] by simp
    then show ?thesis .
  qed
  then show ?case using Forall 0 1 2 by simp
qed

end

Theory Renaming_Auto

theory Renaming_Auto
  imports
    Renaming
    Utils
    ZF.Finite
    ZF.List
  keywords "rename" :: thy_decl % "ML"
    and "simple_rename" :: thy_decl % "ML"
    and "src"
    and "tgt"
  abbrevs "simple_rename" = ""
begin

lemmas app_fun = apply_iff[THEN iffD1]
lemmas nat_succI = nat_succ_iff[THEN iffD2]

ML_file ‹renaming.ML›
MLfun renaming_def mk_ren name from to ctxt =
    let val to = to |> Syntax.read_term ctxt
        val from = from |> Syntax.read_term ctxt
        val (tc_lemma,action_lemma,fvs,r) = mk_ren from to ctxt
        val (tc_lemma,action_lemma) =
          (Renaming.fix_vars tc_lemma fvs ctxt, Renaming.fix_vars action_lemma fvs ctxt)
        val ren_fun_name = Binding.name (name ^ "_fn")
        val ren_fun_def =  Binding.name (name ^ "_fn_def")
        val ren_thm = Binding.name (name ^ "_thm")
    in
      Local_Theory.note   ((ren_thm, []), [tc_lemma,action_lemma]) ctxt |> snd |>
      Local_Theory.define ((ren_fun_name, NoSyn), ((ren_fun_def, []), r)) |> snd      
  end;

MLlocal

  val ren_parser = Parse.position (Parse.string --
      (Parse.$$$ "src" |-- Parse.string --| Parse.$$$ "tgt" -- Parse.string));

  val _ =
   Outer_Syntax.local_theory command_keywordrename "ML setup for synthetic definitions"
     (ren_parser >> (fn ((name,(from,to)),_) => renaming_def Renaming.sum_rename name from to ))

  val _ =
   Outer_Syntax.local_theory command_keywordsimple_rename "ML setup for synthetic definitions"
     (ren_parser >> (fn ((name,(from,to)),_) => renaming_def Renaming.ren_thm name from to ))

in
end
end

File ‹renaming.ML›

(* Builds the finite mapping. *)
structure Renaming = struct
open Utils

fun sum_ f g m n p = @{const Renaming.sum} $ f $ g $ m $ n $ p

fun mk_ren rho rho' ctxt =
  let val rs  = to_ML_list rho
      val rs' = to_ML_list rho'
      val ixs = 0 upto (length rs-1)
      fun err t = "The element " ^ Syntax.string_of_term ctxt t ^ " is missing in the target environment"
      fun mkp i =
          case find_index (fn x => x = nth rs i) rs' of
            ~1 => nth rs i |> err |> error
          |  j => mk_Pair (mk_ZFnat i) (mk_ZFnat j) 
  in  map mkp ixs |> mk_FinSet
  end                           

fun mk_dom_lemma ren rho =
  let val n = rho |> to_ML_list |> length |> mk_ZFnat
  in eq_ n (@{const domain} $ ren) |> tp
end

fun ren_tc_goal fin ren rho rho' =
  let val n = rho |> to_ML_list |> length
      val m = rho' |> to_ML_list |> length
      val fun_ty = if fin then @{const_name "FiniteFun"} else @{const_abbrev "function_space"}
      val ty = Const (fun_ty,@{typ "i  i  i"}) $ mk_ZFnat n $ mk_ZFnat m
  in  mem_ ren ty |> tp
end

fun ren_action_goal ren rho rho' ctxt =
  let val setV = Variable.variant_frees ctxt [] [("A",@{typ i})] |> hd |> Free
      val j = Variable.variant_frees ctxt [] [("j",@{typ i})] |> hd |> Free 
      val vs = rho  |> to_ML_list
      val ws = rho' |> to_ML_list |> filter isFree 
      val h1 = subset_ (vs|> mk_FinSet) setV
      val h2 = lt_ j (mk_ZFnat (length vs))
      val fvs = ([j,setV ] @ ws |> filter isFree) |> map freeName
      val lhs = nth_ j rho
      val rhs = nth_ (app_ ren j)  rho'
      val concl = eq_ lhs rhs
   in (Logic.list_implies([tp h1,tp h2],tp concl),fvs)
  end

  fun sum_tc_goal f m n p = 
    let val m_length = m |> to_ML_list |> length |> mk_ZFnat
        val n_length = n |> to_ML_list |> length |> mk_ZFnat
        val p_length = p |> length_
        val id_fun = @{const id} $ p_length
        val sum_fun = sum_ f id_fun m_length n_length p_length
        val dom = add_ m_length p_length
        val codom = add_ n_length p_length
        val fun_ty = @{const_abbrev "function_space"}
        val ty = Const (fun_ty,@{typ "i  i  i"}) $ dom $ codom
  in  (sum_fun, mem_ sum_fun ty |> tp)
  end

fun sum_action_goal ren rho rho' ctxt =
  let val setV = Variable.variant_frees ctxt [] [("A",@{typ i})] |> hd |> Free
      val envV = Variable.variant_frees ctxt [] [("env",@{typ i})] |> hd |> Free
      val j = Variable.variant_frees ctxt [] [("j",@{typ i})] |> hd |> Free 
      val vs = rho  |> to_ML_list
      val ws = rho' |> to_ML_list |> filter isFree 
      val envL =  envV |> length_
      val rhoL = vs |> length |> mk_ZFnat
      val h1 = subset_ (append vs ws |> mk_FinSet) setV
      val h2 = lt_ j (add_ rhoL envL)
      val h3 = mem_ envV (list_ setV)
      val fvs = ([j,setV,envV] @ ws |> filter isFree) |> map freeName
      val lhs = nth_ j (concat_ rho envV)
      val rhs = nth_ (app_ ren j) (concat_ rho' envV)
      val concl = eq_ lhs rhs
   in (Logic.list_implies([tp h1,tp h2,tp h3],tp concl),fvs)
  end

  (* Tactics *)
  fun fin ctxt = 
         REPEAT (resolve_tac ctxt [@{thm nat_succI}] 1)
         THEN   resolve_tac ctxt [@{thm nat_0I}] 1

  fun step ctxt thm = 
    asm_full_simp_tac ctxt 1
    THEN asm_full_simp_tac ctxt 1
    THEN EqSubst.eqsubst_tac ctxt [1] [@{thm app_fun} OF [thm]] 1
    THEN simp_tac ctxt 1
    THEN simp_tac ctxt 1

  fun fin_fun_tac ctxt = 
    REPEAT (
      resolve_tac ctxt [@{thm consI}] 1
      THEN resolve_tac ctxt [@{thm ltD}] 1
      THEN simp_tac ctxt 1
      THEN resolve_tac ctxt [@{thm ltD}] 1
      THEN simp_tac ctxt 1)
    THEN resolve_tac ctxt [@{thm emptyI}] 1
  THEN REPEAT (simp_tac ctxt 1)

  fun ren_thm e e' ctxt = 
   let
    val r = mk_ren e e' ctxt
    val fin_tc_goal = ren_tc_goal true r e e' 
    val dom_goal =  mk_dom_lemma r e
    val tc_goal = ren_tc_goal false r e e'
    val (action_goal,fvs) = ren_action_goal r e e' ctxt
    val fin_tc_lemma = Goal.prove ctxt [] [] fin_tc_goal (fn _ => fin_fun_tac ctxt)
    val dom_lemma = Goal.prove ctxt [] [] dom_goal (fn _ => blast_tac ctxt 1) 
    val tc_lemma =  Goal.prove ctxt [] [] tc_goal
            (fn _ =>  EqSubst.eqsubst_tac ctxt [1] [dom_lemma] 1
              THEN resolve_tac ctxt [@{thm FiniteFun_is_fun}] 1
              THEN resolve_tac ctxt [fin_tc_lemma] 1)
    val action_lemma = Goal.prove ctxt [] [] action_goal
              (fn _ => 
                  forward_tac ctxt [@{thm le_natI}] 1
                  THEN fin ctxt
                  THEN REPEAT (resolve_tac ctxt [@{thm natE}] 1
                               THEN step ctxt tc_lemma)
                  THEN (step ctxt tc_lemma)
              )
    in (action_lemma, tc_lemma, fvs, r)
  end

(* 
Returns the sum renaming, the goal for type_checking, and the actual lemmas 
for the left part of the sum.
*)
 fun sum_ren_aux e e' ctxt = 
  let val env = Variable.variant_frees ctxt [] [("env",@{typ i})] |> hd |> Free
      val (left_action_lemma,left_tc_lemma,_,r) = ren_thm e e' ctxt
      val (sum_ren,sum_goal_tc) = sum_tc_goal r e e' env
      val setV = Variable.variant_frees ctxt [] [("A",@{typ i})] |> hd |> Free      
      fun hyp en = mem_ en (list_ setV)
  in (sum_ren,
      freeName env,
      Logic.list_implies (map (fn e => e |> hyp |> tp) [env], sum_goal_tc),
      left_tc_lemma,
      left_action_lemma)
end

fun sum_tc_lemma rho rho' ctxt =
  let val (sum_ren, envVar, tc_goal, left_tc_lemma, left_action_lemma) = sum_ren_aux rho rho' ctxt
      val (goal,fvs) = sum_action_goal sum_ren rho rho' ctxt
      val r = mk_ren rho rho' ctxt
  in (sum_ren, goal,envVar, r,left_tc_lemma, left_action_lemma ,fvs, Goal.prove ctxt [] [] tc_goal
               (fn _ =>
            resolve_tac ctxt [@{thm sum_type_id_aux2}] 1
            THEN asm_simp_tac ctxt 4
            THEN simp_tac ctxt 1
            THEN resolve_tac ctxt [left_tc_lemma] 1            
            THEN (fin ctxt)
            THEN (fin ctxt)
  ))
  end

fun sum_rename rho rho' ctxt = 
  let
    val (_, goal, _, left_rename, left_tc_lemma, left_action_lemma, fvs, sum_tc_lemma) = sum_tc_lemma rho rho' ctxt
    val action_lemma = fix_vars left_action_lemma fvs ctxt
  in (sum_tc_lemma, Goal.prove ctxt [] [] goal
    (fn _ => resolve_tac ctxt [@{thm sum_action_id_aux}] 1
            THEN (simp_tac ctxt 4)
            THEN (simp_tac ctxt 1)
            THEN (resolve_tac ctxt [left_tc_lemma]  1)
            THEN (asm_full_simp_tac ctxt 1) 
            THEN (asm_full_simp_tac ctxt 1)
            THEN (simp_tac ctxt 1)
            THEN (simp_tac ctxt 1)
            THEN (simp_tac ctxt 1)
            THEN (full_simp_tac ctxt 1)
            THEN (resolve_tac ctxt [action_lemma] 1)
            THEN (blast_tac ctxt  1)
            THEN (full_simp_tac ctxt  1)
            THEN (full_simp_tac ctxt  1)
    
   ), fvs, left_rename
   )
end ;
end

Theory Names

section‹Names and generic extensions›

theory Names
  imports
    Forcing_Data
    Interface
    Recursion_Thms
    Synthetic_Definition
begin

definition
  SepReplace :: "[i, ii, i o]  i" where
  "SepReplace(A,b,Q)  {y . xA, y=b(x)  Q(x)}"

syntax
  "_SepReplace"  :: "[i, pttrn, i, o]  i"  ("(1{_ ../ _  _, _})")
translations
  "{b .. xA, Q}" => "CONST SepReplace(A, λx. b, λx. Q)"

lemma Sep_and_Replace: "{b(x) .. xA, P(x) } = {b(x) . x{yA. P(y)}}"
  by (auto simp add:SepReplace_def)

lemma SepReplace_subset : "AA' {b .. xA, Q}{b .. xA', Q}"
  by (auto simp add:SepReplace_def)

lemma SepReplace_iff [simp]: "y{b(x) .. xA, P(x)}  (xA. y=b(x) & P(x))"
  by (auto simp add:SepReplace_def)

lemma SepReplace_dom_implies :
  "( x . x A  b(x) = b'(x)) {b(x) .. xA, Q(x)}={b'(x) .. xA, Q(x)}"
  by  (simp add:SepReplace_def)

lemma SepReplace_pred_implies :
  "x. Q(x) b(x) = b'(x) {b(x) .. xA, Q(x)}={b'(x) .. xA, Q(x)}"
  by  (force simp add:SepReplace_def)

subsection‹The well-founded relation termed

lemma eclose_sing : "x  eclose(a)  x  eclose({a})"
  by(rule subsetD[OF mem_eclose_subset],simp+)

lemma ecloseE :
  assumes  "x  eclose(A)"
  shows  "x  A  ( B  A . x  eclose(B))"
  using assms
proof (induct rule:eclose_induct_down)
  case (1 y)
  then
  show ?case
    using arg_into_eclose by auto
next
  case (2 y z)
  from y  A  (BA. y  eclose(B))
  consider (inA) "y  A" | (exB) "(BA. y  eclose(B))"
    by auto
  then show ?case
  proof (cases)
    case inA
    then
    show ?thesis using 2 arg_into_eclose by auto
  next
    case exB
    then obtain B where "y  eclose(B)" "BA"
      by auto
    then
    show ?thesis using 2 ecloseD[of y B z] by auto
  qed
qed

lemma eclose_singE : "x  eclose({a})  x = a  x  eclose(a)"
  by(blast dest: ecloseE)

lemma in_eclose_sing :
  assumes "x  eclose({a})" "a  eclose(z)"
  shows "x  eclose({z})"
proof -
  from xeclose({a})
  consider (eq) "x=a" | (lt) "xeclose(a)"
    using eclose_singE by auto
  then
  show ?thesis
    using eclose_sing mem_eclose_trans assms
    by (cases, auto)
qed

lemma in_dom_in_eclose :
  assumes "x  domain(z)"
  shows "x  eclose(z)"
proof -
  from assms
  obtain y where "x,y  z"
    unfolding domain_def by auto
  then
  show ?thesis
    unfolding Pair_def
    using ecloseD[of "{x,x}"] ecloseD[of "{{x,x},{x,y}}"] arg_into_eclose
    by auto
qed

text‹termed› is the well-founded relation on which termval is defined.›
definition
  ed :: "[i,i]  o" where
  "ed(x,y)  x  domain(y)"

definition
  edrel :: "i  i" where
  "edrel(A)  Rrel(ed,A)"


lemma edI[intro!]: "tdomain(x)  ed(t,x)"
  unfolding ed_def .

lemma edD[dest!]: "ed(t,x)  tdomain(x)"
  unfolding ed_def .


lemma rank_ed:
  assumes "ed(y,x)"
  shows "succ(rank(y))  rank(x)"
proof
  from assms
  obtain p where "y,px" by auto
  moreover
  obtain s where "ys" "sy,p" unfolding Pair_def by auto
  ultimately
  have "rank(y) < rank(s)" "rank(s) < rank(y,p)" "rank(y,p) < rank(x)"
    using rank_lt by blast+
  then
  show "rank(y) < rank(x)"
    using lt_trans by blast
qed

lemma edrel_dest [dest]: "x  edrel(A)   a A.  b  A. x =a,b"
  by(auto simp add:ed_def edrel_def Rrel_def)

lemma edrelD : "x  edrel(A)   a A.  b  A. x =a,b  a  domain(b)"
  by(auto simp add:ed_def edrel_def Rrel_def)

lemma edrelI [intro!]: "xA  yA  x  domain(y)  x,yedrel(A)"
  by (simp add:ed_def edrel_def Rrel_def)

lemma edrel_trans: "Transset(A)  yA  x  domain(y)  x,yedrel(A)"
  by (rule edrelI, auto simp add:Transset_def domain_def Pair_def)

lemma domain_trans: "Transset(A)  yA  x  domain(y)  xA"
  by (auto simp add: Transset_def domain_def Pair_def)

lemma relation_edrel : "relation(edrel(A))"
  by(auto simp add: relation_def)

lemma field_edrel : "field(edrel(A))A"
  by blast

lemma edrel_sub_memrel: "edrel(A)  trancl(Memrel(eclose(A)))"
proof
  fix z
  assume
    "zedrel(A)"
  then obtain x y where
    Eq1:   "xA" "yA" "z=x,y" "xdomain(y)"
    using edrelD
    by blast
  then obtain u v where
    Eq2:   "xu" "uv" "vy"
    unfolding domain_def Pair_def by auto
  with Eq1 have
    Eq3:   "xeclose(A)" "yeclose(A)" "ueclose(A)" "veclose(A)"
    by (auto, rule_tac [3-4] ecloseD, rule_tac [3] ecloseD, simp_all add:arg_into_eclose)
  let
    ?r="trancl(Memrel(eclose(A)))"
  from Eq2 and Eq3 have
    "x,u?r" "u,v?r" "v,y?r"
    by (auto simp add: r_into_trancl)
  then  have
    "x,y?r"
    by (rule_tac trancl_trans, rule_tac [2] trancl_trans, simp)
  with Eq1 show "z?r" by simp
qed

lemma wf_edrel : "wf(edrel(A))"
  using wf_subset [of "trancl(Memrel(eclose(A)))"] edrel_sub_memrel
    wf_trancl wf_Memrel
  by auto

lemma ed_induction:
  assumes "x. y.  ed(y,x)  Q(y)   Q(x)"
  shows "Q(a)"
proof(induct rule: wf_induct2[OF wf_edrel[of "eclose({a})"] ,of a "eclose({a})"])
  case 1
  then show ?case using arg_into_eclose by simp
next
  case 2
  then show ?case using field_edrel .
next
  case (3 x)
  then
  show ?case
    using assms[of x] edrelI domain_trans[OF Transset_eclose 3(1)] by blast
qed

lemma dom_under_edrel_eclose: "edrel(eclose({x})) -`` {x} = domain(x)"
proof
  show "edrel(eclose({x})) -`` {x}  domain(x)"
    unfolding edrel_def Rrel_def ed_def
    by auto
next
  show "domain(x)  edrel(eclose({x})) -`` {x}"
    unfolding edrel_def Rrel_def
    using in_dom_in_eclose eclose_sing arg_into_eclose
    by blast
qed

lemma ed_eclose : "y,z  edrel(A)  y  eclose(z)"
  by(drule edrelD,auto simp add:domain_def in_dom_in_eclose)

lemma tr_edrel_eclose : "y,z  edrel(eclose({x}))^+  y  eclose(z)"
  by(rule trancl_induct,(simp add: ed_eclose mem_eclose_trans)+)


lemma restrict_edrel_eq :
  assumes "z  domain(x)"
  shows "edrel(eclose({x}))  eclose({z})×eclose({z}) = edrel(eclose({z}))"
proof(intro equalityI subsetI)
  let ?ec="λ y . edrel(eclose({y}))"
  let ?ez="eclose({z})"
  let ?rr="?ec(x)  ?ez × ?ez"
  fix y
  assume yr:"y  ?rr"
  with yr obtain a b where 1:"a,b  ?rr" "a  ?ez" "b  ?ez" "a,b  ?ec(x)" "y=a,b"
    by blast
  moreover
  from this
  have "a  domain(b)" using edrelD by blast
  ultimately
  show "y  edrel(eclose({z}))" by blast
next
  let ?ec="λ y . edrel(eclose({y}))"
  let ?ez="eclose({z})"
  let ?rr="?ec(x)  ?ez × ?ez"
  fix y
  assume yr:"y  edrel(?ez)"
  then obtain a b where "a  ?ez" "b  ?ez" "y=a,b" "a  domain(b)"
    using edrelD by blast
  moreover
  from this assms
  have "z  eclose(x)" using in_dom_in_eclose by simp
  moreover
  from assms calculation
  have "a  eclose({x})" "b  eclose({x})" using in_eclose_sing by simp_all
  moreover
  from this adomain(b)
  have "a,b  edrel(eclose({x}))" by blast
  ultimately
  show "y  ?rr" by simp
qed

lemma tr_edrel_subset :
  assumes "z  domain(x)"
  shows   "tr_down(edrel(eclose({x})),z)  eclose({z})"
proof(intro subsetI)
  let ?r="λ x . edrel(eclose({x}))"
  fix y
  assume  "y  tr_down(?r(x),z)"
  then
  have "y,z  ?r(x)^+" using tr_downD by simp
  with assms
  show "y  eclose({z})" using tr_edrel_eclose eclose_sing by simp
qed


context M_ctm
begin

lemma upairM : "x  M  y  M  {x,y}  M"
  by (simp flip: setclass_iff)

lemma singletonM : "a  M  {a}  M"
  by (simp flip: setclass_iff)

lemma Rep_simp : "Replace(u,λ y z . z = f(y)) = { f(y) . y  u}"
  by(auto)

end (* M_ctm *)

subsection‹Values and check-names›
context forcing_data
begin

definition
  Hcheck :: "[i,i]  i" where
  "Hcheck(z,f)   { f`y,one . y  z}"

definition
  check :: "i  i" where
  "check(x)  transrec(x , Hcheck)"

lemma checkD:
  "check(x) =  wfrec(Memrel(eclose({x})), x, Hcheck)"
  unfolding check_def transrec_def ..

definition
  rcheck :: "i  i" where
  "rcheck(x)  Memrel(eclose({x}))^+"


lemma Hcheck_trancl:"Hcheck(y, restrict(f,Memrel(eclose({x}))-``{y}))
                   = Hcheck(y, restrict(f,(Memrel(eclose({x}))^+)-``{y}))"
  unfolding Hcheck_def
  using restrict_trans_eq by simp

lemma check_trancl: "check(x) = wfrec(rcheck(x), x, Hcheck)"
  using checkD wf_eq_trancl Hcheck_trancl unfolding rcheck_def by simp

(* relation of check is in M *)
lemma rcheck_in_M :
  "x  M  rcheck(x)  M"
  unfolding rcheck_def by (simp flip: setclass_iff)


lemma  aux_def_check: "x  y 
  wfrec(Memrel(eclose({y})), x, Hcheck) =
  wfrec(Memrel(eclose({x})), x, Hcheck)"
  by (rule wfrec_eclose_eq,auto simp add: arg_into_eclose eclose_sing)

lemma def_check : "check(y) = { check(w),one . w  y}"
proof -
  let
    ?r="λy. Memrel(eclose({y}))"
  have wfr:   "w . wf(?r(w))" 
    using wf_Memrel ..
  then 
  have "check(y)= Hcheck( y, λx?r(y) -`` {y}. wfrec(?r(y), x, Hcheck))"
    using wfrec[of "?r(y)" y "Hcheck"] checkD by simp
  also 
  have " ... = Hcheck( y, λxy. wfrec(?r(y), x, Hcheck))"
    using under_Memrel_eclose arg_into_eclose by simp
  also 
  have " ... = Hcheck( y, λxy. check(x))"
    using aux_def_check checkD by simp
  finally show ?thesis using Hcheck_def by simp
qed


lemma def_checkS :
  fixes n
  assumes "n  nat"
  shows "check(succ(n)) = check(n)  {check(n),one}"
proof -
  have "check(succ(n)) = {check(i),one . i  succ(n)} "
    using def_check by blast
  also have "... = {check(i),one . i  n}  {check(n),one}"
    by blast
  also have "... = check(n)  {check(n),one}"
    using def_check[of n,symmetric] by simp
  finally show ?thesis .
qed

lemma field_Memrel2 :
  assumes "x  M"
  shows "field(Memrel(eclose({x})))  M"
proof -
  have "field(Memrel(eclose({x})))  eclose({x})" "eclose({x})  M"
    using Ordinal.Memrel_type field_rel_subset assms eclose_least[OF trans_M] by auto
  then
  show ?thesis using subset_trans by simp
qed

definition
  Hv :: "iiii" where
  "Hv(G,x,f)  { f`y .. y domain(x), pP. y,p  x  p  G }"

text‹The funcion termval interprets a name in termM
according to a (generic) filter termG. Note the definition
in terms of the well-founded recursor.›

definition
  val :: "iii" where
  "val(G,τ)  wfrec(edrel(eclose({τ})), τ ,Hv(G))"

lemma aux_def_val:
  assumes "z  domain(x)"
  shows "wfrec(edrel(eclose({x})),z,Hv(G)) = wfrec(edrel(eclose({z})),z,Hv(G))"
proof -
  let ?r="λx . edrel(eclose({x}))"
  have "zeclose({z})" using arg_in_eclose_sing .
  moreover
  have "relation(?r(x))" using relation_edrel .
  moreover
  have "wf(?r(x))" using wf_edrel .
  moreover from assms
  have "tr_down(?r(x),z)  eclose({z})" using tr_edrel_subset by simp
  ultimately
  have "wfrec(?r(x),z,Hv(G)) = wfrec[eclose({z})](?r(x),z,Hv(G))"
    using wfrec_restr by simp
  also from zdomain(x)
  have "... = wfrec(?r(z),z,Hv(G))"
    using restrict_edrel_eq wfrec_restr_eq by simp
  finally show ?thesis .
qed

text‹The next lemma provides the usual recursive expresion for the definition of termval›.›

lemma def_val:  "val(G,x) = {val(G,t) .. tdomain(x) , pP .  t,px  p  G }"
proof -
  let
    ?r="λτ . edrel(eclose({τ}))"
  let
    ?f="λz?r(x)-``{x}. wfrec(?r(x),z,Hv(G))"
  have "τ. wf(?r(τ))" using wf_edrel by simp
  with wfrec [of _ x]
  have "val(G,x) = Hv(G,x,?f)" using val_def by simp
  also
  have " ... = Hv(G,x,λzdomain(x). wfrec(?r(x),z,Hv(G)))"
    using dom_under_edrel_eclose by simp
  also
  have " ... = Hv(G,x,λzdomain(x). val(G,z))"
    using aux_def_val val_def by simp
  finally
  show ?thesis using Hv_def SepReplace_def by simp
qed

lemma val_mono : "xy  val(G,x)  val(G,y)"
  by (subst (1 2) def_val, force)

text‹Check-names are the canonical names for elements of the
ground model. Here we show that this is the case.›

lemma valcheck : "one  G   one  P  val(G,check(y))  = y"
proof (induct rule:eps_induct)
  case (1 y)
  then show ?case
  proof -    
    have "check(y) = { check(w), one . w  y}"  (is "_ = ?C") 
      using def_check .
    then
    have "val(G,check(y)) = val(G, {check(w), one . w  y})"
      by simp
    also
    have " ...  = {val(G,t) .. tdomain(?C) , pP .  t, p?C  p  G }"
      using def_val by blast
    also
    have " ... =  {val(G,t) .. tdomain(?C) , wy. t=check(w) }"
      using 1 by simp
    also
    have " ... = {val(G,check(w)) . wy }"
      by force
    finally
    show "val(G,check(y)) = y"
      using 1 by simp
  qed
qed

lemma val_of_name :
  "val(G,{xA×P. Q(x)}) = {val(G,t) .. tA , pP .  Q(t,p)  p  G }"
proof -
  let
    ?n="{xA×P. Q(x)}" and
    ?r="λτ . edrel(eclose({τ}))"
  let
    ?f="λz?r(?n)-``{?n}. val(G,z)"
  have
    wfR : "wf(?r(τ))" for τ
    by (simp add: wf_edrel)
  have "domain(?n)  A" by auto
  { fix t
    assume H:"t  domain({x  A × P . Q(x)})"
    then have "?f ` t = (if t  ?r(?n)-``{?n} then val(G,t) else 0)"
      by simp
    moreover have "... = val(G,t)"
      using dom_under_edrel_eclose H if_P by auto
  }
  then
  have Eq1: "t  domain({x  A × P . Q(x)})  val(G,t) = ?f` t"  for t
    by simp
  have "val(G,?n) = {val(G,t) .. tdomain(?n), p  P . t,p  ?n  p  G}"
    by (subst def_val,simp)
  also
  have "... = {?f`t .. tdomain(?n), pP . t,p?n  pG}"
    unfolding Hv_def
    by (subst SepReplace_dom_implies,auto simp add:Eq1)
  also
  have  "... = { (if t?r(?n)-``{?n} then val(G,t) else 0) .. tdomain(?n), pP . t,p?n  pG}"
    by (simp)
  also
  have Eq2:  "... = { val(G,t) .. tdomain(?n), pP . t,p?n  pG}"
  proof -
    have "domain(?n)  ?r(?n)-``{?n}"
      using dom_under_edrel_eclose by simp
    then
    have "tdomain(?n). (if t?r(?n)-``{?n} then val(G,t) else 0) = val(G,t)"
      by auto
    then
    show "{ (if t?r(?n)-``{?n} then val(G,t) else 0) .. tdomain(?n), pP . t,p?n  pG} =
          { val(G,t) .. tdomain(?n), pP . t,p?n  pG}"
      by auto
  qed
  also
  have " ... = { val(G,t) .. tA, pP . t,p?n  pG}"
    by force
  finally
  show " val(G,?n)  = { val(G,t) .. tA, pP . Q(t,p)  pG}"
    by auto
qed

lemma val_of_name_alt :
  "val(G,{xA×P. Q(x)}) = {val(G,t) .. tA , pPG .  Q(t,p) }"
  using val_of_name by force

lemma val_only_names: "val(F,τ) = val(F,{xτ. tdomain(τ). pP. x=t,p})"
  (is "_ = val(F,?name)")
proof -
  have "val(F,?name) = {val(F, t).. tdomain(?name), pP. t, p  ?name  p  F}"
    using def_val by blast
  also
  have " ... = {val(F, t). t{ydomain(?name). pP. y, p  ?name  p  F}}"
    using Sep_and_Replace by simp
  also
  have " ... = {val(F, t). t{ydomain(τ). pP. y, p  τ  p  F}}"
    by blast
  also
  have " ... = {val(F, t).. tdomain(τ), pP. t, p  τ  p  F}"
    using Sep_and_Replace by simp
  also
  have " ... = val(F, τ)"
    using def_val[symmetric] by blast
  finally
  show ?thesis ..
qed

lemma val_only_pairs: "val(F,τ) = val(F,{xτ. t p. x=t,p})"
proof
  have "val(F,τ) = val(F,{xτ. tdomain(τ). pP. x=t,p})"
    (is "_ = val(F,?name)")
    using val_only_names .
  also
  have "...  val(F,{xτ. t p. x=t,p})"
    using val_mono[of ?name "{xτ. t p. x=t,p}"] by auto
  finally
  show "val(F,τ)  val(F,{xτ. t p. x=t,p})" by simp
next
  show "val(F,{xτ. t p. x=t,p})  val(F,τ)"
    using val_mono[of "{xτ. t p. x=t,p}"] by auto
qed

lemma val_subset_domain_times_range: "val(F,τ)  val(F,domain(τ)×range(τ))"
  using val_only_pairs[THEN equalityD1]
    val_mono[of "{x  τ . t p. x = t, p}" "domain(τ)×range(τ)"] by blast

lemma val_subset_domain_times_P: "val(F,τ)  val(F,domain(τ)×P)"
  using val_only_names[of F τ] val_mono[of "{xτ. tdomain(τ). pP. x=t,p}" "domain(τ)×P" F]
  by auto

definition
  GenExt :: "ii"     ("M[_]")
  where "GenExt(G) {val(G,τ). τ  M}"


lemma val_of_elem: "θ,p  π  pG  pP  val(G,θ)  val(G,π)"
proof -
  assume
    "θ,p  π"
  then
  have "θdomain(π)" by auto
  assume "pG" "pP"
  with θdomain(π) θ,p  π
  have "val(G,θ)  {val(G,t) .. tdomain(π) , pP .  t, pπ  p  G }"
    by auto
  then
  show ?thesis by (subst def_val)
qed

lemma elem_of_val: "xval(G,π)  θdomain(π). val(G,θ) = x"
  by (subst (asm) def_val,auto)

lemma elem_of_val_pair: "xval(G,π)  θ. pG.  θ,pπ  val(G,θ) = x"
  by (subst (asm) def_val,auto)

lemma elem_of_val_pair':
  assumes "πM" "xval(G,π)"
  shows "θM. pG.  θ,pπ  val(G,θ) = x"
proof -
  from assms
  obtain θ p where "pG" "θ,pπ" "val(G,θ) = x"
    using elem_of_val_pair by blast
  moreover from this πM
  have "θM"
    using pair_in_M_iff[THEN iffD1, THEN conjunct1, simplified]
      transitivity by blast
  ultimately
  show ?thesis by blast
qed


lemma GenExtD:
  "x  M[G]  τM. x = val(G,τ)"
  by (simp add:GenExt_def)

lemma GenExtI:
  "x  M  val(G,x)  M[G]"
  by (auto simp add: GenExt_def)

lemma Transset_MG : "Transset(M[G])"
proof -
  { fix vc y
    assume "vc  M[G]" and "y  vc"
    then obtain c where "cM" "val(G,c)M[G]" "y  val(G,c)"
      using GenExtD by auto
    from y  val(G,c)
    obtain θ where "θdomain(c)" "val(G,θ) = y"
      using elem_of_val by blast
    with trans_M cM
    have "y  M[G]"
      using domain_trans GenExtI by blast
  }
  then
  show ?thesis using Transset_def by auto
qed

lemmas transitivity_MG = Transset_intf[OF Transset_MG]

lemma check_n_M :
  fixes n
  assumes "n  nat"
  shows "check(n)  M"
  using nnat›
proof (induct n)
  case 0
  then show ?case using zero_in_M by (subst def_check,simp)
next
  case (succ x)
  have "one  M" using one_in_P P_sub_M subsetD by simp
  with ‹check(x)M
  have "check(x),one  M"
    using tuples_in_M by simp
  then
  have "{check(x),one}  M"
    using singletonM by simp
  with ‹check(x)M
  have "check(x)  {check(x),one}  M"
    using Un_closed by simp
  then show ?case using xnat› def_checkS by simp
qed


definition
  PHcheck :: "[i,i,i,i]  o" where
  "PHcheck(o,f,y,p)  pM  (fy[##M]. fun_apply(##M,f,y,fy)  pair(##M,fy,o,p))"

definition
  is_Hcheck :: "[i,i,i,i]  o" where
  "is_Hcheck(o,z,f,hc)   is_Replace(##M,z,PHcheck(o,f),hc)"

lemma one_in_M: "one  M"
  by (insert one_in_P P_in_M, simp add: transitivity)

lemma def_PHcheck:
  assumes
    "zM" "fM"
  shows
    "Hcheck(z,f) = Replace(z,PHcheck(one,f))"
proof -
  from assms
  have "f`x,one  M" "f`xM" if "xz" for x
    using tuples_in_M one_in_M transitivity that apply_closed by simp_all
  then
  have "{y . x  z, y = f ` x, one} =  {y . x  z, y = f ` x, one  yM  f`xM}"
    by simp
  then
  show ?thesis
    using zM fM transitivity
    unfolding Hcheck_def PHcheck_def RepFun_def
    by auto
qed

(*
  "PHcheck(o,f,y,p) ≡ ∃fy[##M]. fun_apply(##M,f,y,fy) ∧ pair(##M,fy,o,p)"
*)
definition
  PHcheck_fm :: "[i,i,i,i]  i" where
  "PHcheck_fm(o,f,y,p)  Exists(And(fun_apply_fm(succ(f),succ(y),0)
                                 ,pair_fm(0,succ(o),succ(p))))"

lemma PHcheck_type [TC]:
  " x  nat; y  nat; z  nat; u  nat   PHcheck_fm(x,y,z,u)  formula"
  by (simp add:PHcheck_fm_def)

lemma sats_PHcheck_fm [simp]:
  " x  nat; y  nat; z  nat; u  nat ; env  list(M)
     sats(M,PHcheck_fm(x,y,z,u),env) 
        PHcheck(nth(x,env),nth(y,env),nth(z,env),nth(u,env))"
  using zero_in_M Internalizations.nth_closed by (simp add: PHcheck_def PHcheck_fm_def)

(*
  "is_Hcheck(o,z,f,hc)  ≡ is_Replace(##M,z,PHcheck(o,f),hc)"
*)
definition
  is_Hcheck_fm :: "[i,i,i,i]  i" where
  "is_Hcheck_fm(o,z,f,hc)  Replace_fm(z,PHcheck_fm(succ(succ(o)),succ(succ(f)),0,1),hc)"

lemma is_Hcheck_type [TC]:
  " x  nat; y  nat; z  nat; u  nat   is_Hcheck_fm(x,y,z,u)  formula"
  by (simp add:is_Hcheck_fm_def)

lemma sats_is_Hcheck_fm [simp]:
  " x  nat; y  nat; z  nat; u  nat ; env  list(M)
     sats(M,is_Hcheck_fm(x,y,z,u),env) 
        is_Hcheck(nth(x,env),nth(y,env),nth(z,env),nth(u,env))"
  using sats_Replace_fm unfolding is_Hcheck_def is_Hcheck_fm_def
  by simp


(* instance of replacement for hcheck *)
lemma wfrec_Hcheck :
  assumes
    "XM"
  shows
    "wfrec_replacement(##M,is_Hcheck(one),rcheck(X))"
proof -
  have "is_Hcheck(one,a,b,c) 
        sats(M,is_Hcheck_fm(8,2,1,0),[c,b,a,d,e,y,x,z,one,rcheck(x)])"
    if "aM" "bM" "cM" "dM" "eM" "yM" "xM" "zM"
    for a b c d e y x z
    using that one_in_M XM rcheck_in_M by simp
  then have 1:"sats(M,is_wfrec_fm(is_Hcheck_fm(8,2,1,0),4,1,0),
                    [y,x,z,one,rcheck(X)]) 
            is_wfrec(##M, is_Hcheck(one),rcheck(X), x, y)"
    if "xM" "yM" "zM" for x y z
    using  that sats_is_wfrec_fm XM rcheck_in_M one_in_M by simp
  let
    ?f="Exists(And(pair_fm(1,0,2),
               is_wfrec_fm(is_Hcheck_fm(8,2,1,0),4,1,0)))"
  have satsf:"sats(M, ?f, [x,z,one,rcheck(X)]) 
              (yM. pair(##M,x,y,z) & is_wfrec(##M, is_Hcheck(one),rcheck(X), x, y))"
    if "xM" "zM" for x z
    using that 1 XM rcheck_in_M one_in_M by (simp del:pair_abs)
  have artyf:"arity(?f) = 4"
    unfolding is_wfrec_fm_def is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def
      pair_fm_def upair_fm_def is_recfun_fm_def fun_apply_fm_def big_union_fm_def
      pre_image_fm_def restriction_fm_def image_fm_def
    by (simp add:nat_simp_union)
  then
  have "strong_replacement(##M,λx z. sats(M,?f,[x,z,one,rcheck(X)]))"
    using replacement_ax 1 artyf XM rcheck_in_M one_in_M by simp
  then
  have "strong_replacement(##M,λx z.
          yM. pair(##M,x,y,z) & is_wfrec(##M, is_Hcheck(one),rcheck(X), x, y))"
    using repl_sats[of M ?f "[one,rcheck(X)]"] satsf by (simp del:pair_abs)
  then
  show ?thesis unfolding wfrec_replacement_def by simp
qed

lemma repl_PHcheck :
  assumes
    "fM"
  shows
    "strong_replacement(##M,PHcheck(one,f))"
proof -
  have "arity(PHcheck_fm(2,3,0,1)) = 4"
    unfolding PHcheck_fm_def fun_apply_fm_def big_union_fm_def pair_fm_def image_fm_def
      upair_fm_def
    by (simp add:nat_simp_union)
  with fM
  have "strong_replacement(##M,λx y. sats(M,PHcheck_fm(2,3,0,1),[x,y,one,f]))"
    using replacement_ax one_in_M by simp
  with fM
  show ?thesis using one_in_M unfolding strong_replacement_def univalent_def by simp
qed

lemma univ_PHcheck : " zM ; fM   univalent(##M,z,PHcheck(one,f))"
  unfolding univalent_def PHcheck_def by simp

lemma relation2_Hcheck :
  "relation2(##M,is_Hcheck(one),Hcheck)"
proof -
  have 1:"xz; PHcheck(one,f,x,y)   (##M)(y)"
    if "zM" "fM" for z f x y
    using that unfolding PHcheck_def by simp
  have "is_Replace(##M,z,PHcheck(one,f),hc)  hc = Replace(z,PHcheck(one,f))"
    if "zM" "fM" "hcM" for z f hc
    using that Replace_abs[OF _ _ univ_PHcheck 1] by simp
  with def_PHcheck
  show ?thesis
    unfolding relation2_def is_Hcheck_def Hcheck_def by simp
qed

lemma PHcheck_closed :
  "zM ; fM ; xz; PHcheck(one,f,x,y)   (##M)(y)"
  unfolding PHcheck_def by simp

lemma Hcheck_closed :
  "yM. gM. function(g)  Hcheck(y,g)M"
proof -
  have "Replace(y,PHcheck(one,f))M" if "fM" "yM" for f y
    using that repl_PHcheck  PHcheck_closed[of y f] univ_PHcheck
      strong_replacement_closed
    by (simp flip: setclass_iff)
  then show ?thesis using def_PHcheck by auto
qed

lemma wf_rcheck : "xM  wf(rcheck(x))"
  unfolding rcheck_def using wf_trancl[OF wf_Memrel] .

lemma trans_rcheck : "xM  trans(rcheck(x))"
  unfolding rcheck_def using trans_trancl .

lemma relation_rcheck : "xM  relation(rcheck(x))"
  unfolding rcheck_def using relation_trancl .

lemma check_in_M : "xM  check(x)  M"
  unfolding transrec_def
  using wfrec_Hcheck[of x] check_trancl wf_rcheck trans_rcheck relation_rcheck rcheck_in_M
    Hcheck_closed relation2_Hcheck trans_wfrec_closed[of "rcheck(x)" x "is_Hcheck(one)" Hcheck]
  by (simp flip: setclass_iff)

end (* forcing_data *)

(* check if this should go to Relative! *)
definition
  is_singleton :: "[io,i,i]  o" where
  "is_singleton(A,x,z)  c[A]. empty(A,c)  is_cons(A,x,c,z)"

lemma (in M_trivial) singleton_abs[simp] : " M(x) ; M(s)   is_singleton(M,x,s)  s = {x}"
  unfolding is_singleton_def using nonempty by simp

definition
  singleton_fm :: "[i,i]  i" where
  "singleton_fm(i,j)  Exists(And(empty_fm(0), cons_fm(succ(i),0,succ(j))))"

lemma singleton_type[TC] : " x  nat; y  nat   singleton_fm(x,y)  formula"
  unfolding singleton_fm_def by simp

lemma is_singleton_iff_sats:
  " nth(i,env) = x; nth(j,env) = y;
          i  nat; jnat ; env  list(A)
        is_singleton(##A,x,y)  sats(A, singleton_fm(i,j), env)"
  unfolding is_singleton_def singleton_fm_def by simp

context forcing_data begin

(* Internalization and absoluteness of rcheck *)
definition
  is_rcheck :: "[i,i]  o" where
  "is_rcheck(x,z)  rM. tran_closure(##M,r,z)  (ecM. membership(##M,ec,r) 
                           (sM. is_singleton(##M,x,s)   is_eclose(##M,s,ec)))"

lemma rcheck_abs :
  " xM ; rM   is_rcheck(x,r)  r = rcheck(x)"
  unfolding rcheck_def is_rcheck_def
  using singletonM trancl_closed Memrel_closed eclose_closed by simp

schematic_goal rcheck_fm_auto:
  assumes
    "i  nat" "j  nat" "env  list(M)"
  shows
    "is_rcheck(nth(i,env),nth(j,env))  sats(M,?rch(i,j),env)"
  unfolding is_rcheck_def
  by (insert assms ; (rule sep_rules is_singleton_iff_sats is_eclose_iff_sats
        trans_closure_fm_iff_sats | simp)+)

synthesize "rcheck_fm" from_schematic rcheck_fm_auto

definition
  is_check :: "[i,i]  o" where
  "is_check(x,z)  rchM. is_rcheck(x,rch)  is_wfrec(##M,is_Hcheck(one),rch,x,z)"

lemma check_abs :
  assumes
    "xM" "zM"
  shows
    "is_check(x,z)  z = check(x)"
proof -
  have
    "is_check(x,z)  is_wfrec(##M,is_Hcheck(one),rcheck(x),x,z)"
    unfolding is_check_def using assms rcheck_abs rcheck_in_M
    unfolding check_trancl is_check_def by simp
  then show ?thesis
    unfolding check_trancl
    using assms wfrec_Hcheck[of x] wf_rcheck trans_rcheck relation_rcheck rcheck_in_M
      Hcheck_closed relation2_Hcheck trans_wfrec_abs[of "rcheck(x)" x z "is_Hcheck(one)" Hcheck]
    by (simp flip: setclass_iff)
qed

(* ∃rch∈M. is_rcheck(x,rch) ∧ is_wfrec(##M,is_Hcheck(one),rch,x,z) *)
definition
  check_fm :: "[i,i,i]  i" where
  "check_fm(x,o,z)  Exists(And(rcheck_fm(1#+x,0),
                      is_wfrec_fm(is_Hcheck_fm(6#+o,2,1,0),0,1#+x,1#+z)))"

lemma check_fm_type[TC] :
  "xnat;onat;znat  check_fm(x,o,z)formula"
  unfolding check_fm_def by simp

lemma sats_check_fm :
  assumes
    "nth(o,env) = one" "xnat" "znat" "onat" "envlist(M)" "x < length(env)" "z < length(env)"
  shows
    "sats(M, check_fm(x,o,z), env)  is_check(nth(x,env),nth(z,env))"
proof -
  have sats_is_Hcheck_fm:
    "a0 a1 a2 a3 a4.  a0M; a1M; a2M; a3M; a4M  
         is_Hcheck(one,a2, a1, a0) 
         sats(M, is_Hcheck_fm(6#+o,2,1,0), [a0,a1,a2,a3,a4,r]@env)" if "rM" for r
    using that one_in_M assms  by simp
  then
  have "sats(M, is_wfrec_fm(is_Hcheck_fm(6#+o,2,1,0),0,1#+x,1#+z),Cons(r,env))
         is_wfrec(##M,is_Hcheck(one),r,nth(x,env),nth(z,env))" if "rM" for r
    using that assms one_in_M sats_is_wfrec_fm by simp
  then
  show ?thesis unfolding is_check_def check_fm_def
    using assms rcheck_in_M one_in_M rcheck_fm_iff_sats[symmetric] by simp
qed


lemma check_replacement:
  "{check(x). xP}  M"
proof -
  have "arity(check_fm(0,2,1)) = 3"
    unfolding check_fm_def rcheck_fm_def trans_closure_fm_def is_eclose_fm_def mem_eclose_fm_def
      is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def finite_ordinal_fm_def is_iterates_fm_def
      is_wfrec_fm_def is_recfun_fm_def restriction_fm_def pre_image_fm_def eclose_n_fm_def
      is_nat_case_fm_def quasinat_fm_def Memrel_fm_def singleton_fm_def fm_defs iterates_MH_fm_def
    by (simp add:nat_simp_union)
  moreover
  have "check(x)M" if "xP" for x
    using that Transset_intf[of M x P] trans_M check_in_M P_in_M by simp
  ultimately
  show ?thesis using sats_check_fm check_abs P_in_M check_in_M one_in_M
      Repl_in_M[of "check_fm(0,2,1)" "[one]" is_check check] by simp
qed

lemma pair_check : " pM ; yM    (cM. is_check(p,c)  pair(##M,c,p,y))  y = check(p),p"
  using check_abs check_in_M tuples_in_M by simp


lemma M_subset_MG :  "one  G  M  M[G]"
  using check_in_M one_in_P GenExtI
  by (intro subsetI, subst valcheck [of G,symmetric], auto)

text‹The name for the generic filter›
definition
  G_dot :: "i" where
  "G_dot  {check(p),p . pP}"

lemma G_dot_in_M :
  "G_dot  M"
proof -
  let ?is_pcheck = "λx y. chM. is_check(x,ch)  pair(##M,ch,x,y)"
  let ?pcheck_fm = "Exists(And(check_fm(1,3,0),pair_fm(0,1,2)))"
  have "sats(M,?pcheck_fm,[x,y,one])  ?is_pcheck(x,y)" if "xM" "yM" for x y
    using sats_check_fm that one_in_M by simp
  moreover
  have "?is_pcheck(x,y)  y = check(x),x" if "xM" "yM" for x y
    using that check_abs check_in_M by simp
  moreover
  have "?pcheck_fmformula" by simp
  moreover
  have "arity(?pcheck_fm)=3"
    unfolding check_fm_def rcheck_fm_def trans_closure_fm_def is_eclose_fm_def mem_eclose_fm_def
      is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def finite_ordinal_fm_def is_iterates_fm_def
      is_wfrec_fm_def is_recfun_fm_def restriction_fm_def pre_image_fm_def eclose_n_fm_def
      is_nat_case_fm_def quasinat_fm_def Memrel_fm_def singleton_fm_def fm_defs iterates_MH_fm_def
    by (simp add:nat_simp_union)
  moreover
  from P_in_M check_in_M tuples_in_M P_sub_M
  have "check(p),p  M" if "pP" for p
    using that by auto
  ultimately
  show ?thesis
    unfolding G_dot_def
    using one_in_M P_in_M Repl_in_M[of ?pcheck_fm "[one]"]
    by simp
qed


lemma val_G_dot :
  assumes "G  P"
    "one  G"
  shows "val(G,G_dot) = G"
proof (intro equalityI subsetI)
  fix x
  assume "xval(G,G_dot)"
  then obtain θ p where "pG" "θ,p  G_dot" "val(G,θ) = x" "θ = check(p)"
    unfolding G_dot_def using elem_of_val_pair G_dot_in_M
    by force
  with oneG GP show
    "x  G"
    using valcheck P_sub_M by auto
next
  fix p
  assume "pG"
  have "check(q),q  G_dot" if "qP" for q
    unfolding G_dot_def using that by simp
  with pG GP
  have "val(G,check(p))  val(G,G_dot)"
    using val_of_elem G_dot_in_M by blast
  with pG GP oneG
  show "p  val(G,G_dot)"
    using P_sub_M valcheck by auto
qed


lemma G_in_Gen_Ext :
  assumes "G  P" and "one  G"
  shows   "G  M[G]"
  using assms val_G_dot GenExtI[of _ G] G_dot_in_M
  by force

(* Move this to M_trivial *)
lemma fst_snd_closed: "pM  fst(p)  M  snd(p) M"
proof (cases "a. b. p = a, b")
  case False
  then
  show "fst(p)  M  snd(p)  M" unfolding fst_def snd_def using zero_in_M by auto
next
  case True
  then
  obtain a b where "p = a, b" by blast
  with True
  have "fst(p) = a" "snd(p) = b" unfolding fst_def snd_def by simp_all
  moreover
  assume "pM"
  moreover from this
  have "aM"
    unfolding p = _ Pair_def by (force intro:Transset_M[OF trans_M])
  moreover from  pM
  have "bM"
    using Transset_M[OF trans_M, of "{a,b}" p] Transset_M[OF trans_M, of "b" "{a,b}"]
    unfolding p = _ Pair_def by (simp)
  ultimately
  show ?thesis by simp
qed

end (* forcing_data *)

locale G_generic = forcing_data +
  fixes G :: "i"
  assumes generic : "M_generic(G)"
begin

lemma zero_in_MG :
  "0  M[G]"
proof -
  have "0 = val(G,0)"
    using zero_in_M elem_of_val by auto
  also 
  have "...  M[G]"
    using GenExtI zero_in_M by simp
  finally show ?thesis .
qed

lemma G_nonempty: "G0"
proof -
  have "PP" ..
  with P_in_M P_dense PP
  show "G  0"
    using generic unfolding M_generic_def by auto
qed

end (* context G_generic *)
end

Theory FrecR

section‹Well-founded relation on names›
theory FrecR imports Names Synthetic_Definition begin

lemmas sep_rules' = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
  fun_plus_iff_sats omega_iff_sats FOL_sats_iff 

texttermfrecR is the well-founded relation on names that allows
us to define forcing for atomic formulas.›

(* MOVE THIS. absoluteness of higher-order composition *)
definition
  is_hcomp :: "[io,iio,iio,i,i]  o" where
  "is_hcomp(M,is_f,is_g,a,w)  z[M]. is_g(a,z)  is_f(z,w)" 

lemma (in M_trivial) hcomp_abs: 
  assumes
    is_f_abs:"a z. M(a)  M(z)  is_f(a,z)  z = f(a)" and
    is_g_abs:"a z. M(a)  M(z)  is_g(a,z)  z = g(a)" and
    g_closed:"a. M(a)  M(g(a))" 
    "M(a)" "M(w)" 
  shows
    "is_hcomp(M,is_f,is_g,a,w)  w = f(g(a))" 
  unfolding is_hcomp_def using assms by simp

definition
  hcomp_fm :: "[iii,iii,i,i]  i" where
  "hcomp_fm(pf,pg,a,w)  Exists(And(pg(succ(a),0),pf(0,succ(w))))"

lemma sats_hcomp_fm:
  assumes 
    f_iff_sats:"a b z. anat  bnat  zM  
                 is_f(nth(a,Cons(z,env)),nth(b,Cons(z,env)))  sats(M,pf(a,b),Cons(z,env))"
    and
    g_iff_sats:"a b z. anat  bnat  zM  
                is_g(nth(a,Cons(z,env)),nth(b,Cons(z,env)))  sats(M,pg(a,b),Cons(z,env))"
    and
    "anat" "wnat" "envlist(M)" 
  shows
    "sats(M,hcomp_fm(pf,pg,a,w),env)  is_hcomp(##M,is_f,is_g,nth(a,env),nth(w,env))" 
proof -
  have "sats(M, pf(0, succ(w)), Cons(x, env))  is_f(x,nth(w,env))" if "xM" "wnat" for x w
    using f_iff_sats[of 0 "succ(w)" x] that by simp
  moreover
  have "sats(M, pg(succ(a), 0), Cons(x, env))  is_g(nth(a,env),x)" if "xM" "anat" for x a
    using g_iff_sats[of "succ(a)" 0 x] that by simp
  ultimately
  show ?thesis unfolding hcomp_fm_def is_hcomp_def using assms by simp
qed


(* Preliminary *)
definition
  ftype :: "ii" where
  "ftype  fst"

definition
  name1 :: "ii" where
  "name1(x)  fst(snd(x))"

definition
  name2 :: "ii" where
  "name2(x)  fst(snd(snd(x)))"

definition
  cond_of :: "ii" where
  "cond_of(x)  snd(snd(snd((x))))"

lemma components_simp:
  "ftype(f,n1,n2,c) = f"
  "name1(f,n1,n2,c) = n1"
  "name2(f,n1,n2,c) = n2"
  "cond_of(f,n1,n2,c) = c"
  unfolding ftype_def name1_def name2_def cond_of_def
  by simp_all

definition eclose_n :: "[ii,i]  i" where
  "eclose_n(name,x) = eclose({name(x)})"

definition
  ecloseN :: "i  i" where
  "ecloseN(x) = eclose_n(name1,x)  eclose_n(name2,x)"

lemma components_in_eclose :
  "n1  ecloseN(f,n1,n2,c)"
  "n2  ecloseN(f,n1,n2,c)"
  unfolding ecloseN_def eclose_n_def
  using components_simp arg_into_eclose by auto

lemmas names_simp = components_simp(2) components_simp(3)

lemma ecloseNI1 : 
  assumes "x  eclose(n1)  xeclose(n2)" 
  shows "x  ecloseN(f,n1,n2,c)" 
  unfolding ecloseN_def eclose_n_def
  using assms eclose_sing names_simp
  by auto

lemmas ecloseNI = ecloseNI1

lemma ecloseN_mono :
  assumes "u  ecloseN(x)" "name1(x)  ecloseN(y)" "name2(x)  ecloseN(y)"
  shows "u  ecloseN(y)"
proof -
  from u_
  consider (a) "ueclose({name1(x)})" | (b) "u  eclose({name2(x)})"
    unfolding ecloseN_def  eclose_n_def by auto
  then 
  show ?thesis
  proof cases
    case a
    with ‹name1(x)  _
    show ?thesis 
      unfolding ecloseN_def  eclose_n_def
      using eclose_singE[OF a] mem_eclose_trans[of u "name1(x)" ] by auto 
  next
    case b
    with ‹name2(x)  _
    show ?thesis 
      unfolding ecloseN_def eclose_n_def
      using eclose_singE[OF b] mem_eclose_trans[of u "name2(x)"] by auto
  qed
qed


(* ftype(p) ≡ THE a. ∃b. p = ⟨a, b⟩ *)

definition
  is_fst :: "(io)iio" where
  "is_fst(M,x,t)  (z[M]. pair(M,t,z,x))  
                       (¬(z[M]. w[M]. pair(M,w,z,x))  empty(M,t))"

definition
  fst_fm :: "[i,i]  i" where
  "fst_fm(x,t)  Or(Exists(pair_fm(succ(t),0,succ(x))),
                   And(Neg(Exists(Exists(pair_fm(0,1,2 #+ x)))),empty_fm(t)))"

lemma sats_fst_fm :
  " x  nat; y  nat;env  list(A)  
     sats(A, fst_fm(x,y), env) 
        is_fst(##A, nth(x,env), nth(y,env))"
  by (simp add: fst_fm_def is_fst_def)

definition 
  is_ftype :: "(io)iio" where
  "is_ftype  is_fst" 

definition
  ftype_fm :: "[i,i]  i" where
  "ftype_fm  fst_fm" 

lemma sats_ftype_fm :
  " x  nat; y  nat;env  list(A)  
     sats(A, ftype_fm(x,y), env) 
        is_ftype(##A, nth(x,env), nth(y,env))"
  unfolding ftype_fm_def is_ftype_def
  by (simp add:sats_fst_fm)

lemma is_ftype_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "anat" "bnat" "env  list(A)"
  shows
    "is_ftype(##A,aa,bb)   sats(A,ftype_fm(a,b), env)"
  using assms
  by (simp add:sats_ftype_fm)

definition
  is_snd :: "(io)iio" where
  "is_snd(M,x,t)  (z[M]. pair(M,z,t,x))  
                       (¬(z[M]. w[M]. pair(M,z,w,x))  empty(M,t))"

definition
  snd_fm :: "[i,i]  i" where
  "snd_fm(x,t)  Or(Exists(pair_fm(0,succ(t),succ(x))),
                   And(Neg(Exists(Exists(pair_fm(1,0,2 #+ x)))),empty_fm(t)))"

lemma sats_snd_fm :
  " x  nat; y  nat;env  list(A)  
     sats(A, snd_fm(x,y), env) 
        is_snd(##A, nth(x,env), nth(y,env))"
  by (simp add: snd_fm_def is_snd_def)

definition
  is_name1 :: "(io)iio" where
  "is_name1(M,x,t2)  is_hcomp(M,is_fst(M),is_snd(M),x,t2)"

definition
  name1_fm :: "[i,i]  i" where
  "name1_fm(x,t)  hcomp_fm(fst_fm,snd_fm,x,t)" 

lemma sats_name1_fm :
  " x  nat; y  nat;env  list(A)  
     sats(A, name1_fm(x,y), env) 
        is_name1(##A, nth(x,env), nth(y,env))"
  unfolding name1_fm_def is_name1_def using sats_fst_fm sats_snd_fm 
    sats_hcomp_fm[of A "is_fst(##A)" _ fst_fm "is_snd(##A)"] by simp

lemma is_name1_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "anat" "bnat" "env  list(A)"
  shows
    "is_name1(##A,aa,bb)   sats(A,name1_fm(a,b), env)"
  using assms
  by (simp add:sats_name1_fm)

definition
  is_snd_snd :: "(io)iio" where
  "is_snd_snd(M,x,t)  is_hcomp(M,is_snd(M),is_snd(M),x,t)"

definition
  snd_snd_fm :: "[i,i]i" where
  "snd_snd_fm(x,t)  hcomp_fm(snd_fm,snd_fm,x,t)"

lemma sats_snd2_fm :
  " x  nat; y  nat;env  list(A)  
     sats(A,snd_snd_fm(x,y), env) 
        is_snd_snd(##A, nth(x,env), nth(y,env))"
  unfolding snd_snd_fm_def is_snd_snd_def using sats_snd_fm 
    sats_hcomp_fm[of A "is_snd(##A)" _ snd_fm "is_snd(##A)"] by simp

definition
  is_name2 :: "(io)iio" where
  "is_name2(M,x,t3)  is_hcomp(M,is_fst(M),is_snd_snd(M),x,t3)"

definition
  name2_fm :: "[i,i]  i" where
  "name2_fm(x,t3)  hcomp_fm(fst_fm,snd_snd_fm,x,t3)"

lemma sats_name2_fm :
  " x  nat; y  nat;env  list(A)  
     sats(A,name2_fm(x,y), env) 
        is_name2(##A, nth(x,env), nth(y,env))"
  unfolding name2_fm_def is_name2_def using sats_fst_fm sats_snd2_fm
    sats_hcomp_fm[of A "is_fst(##A)" _ fst_fm "is_snd_snd(##A)"] by simp

lemma is_name2_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "anat" "bnat" "env  list(A)"
  shows
    "is_name2(##A,aa,bb)   sats(A,name2_fm(a,b), env)"
  using assms
  by (simp add:sats_name2_fm)

definition
  is_cond_of :: "(io)iio" where
  "is_cond_of(M,x,t4)  is_hcomp(M,is_snd(M),is_snd_snd(M),x,t4)"

definition
  cond_of_fm :: "[i,i]  i" where
  "cond_of_fm(x,t4)  hcomp_fm(snd_fm,snd_snd_fm,x,t4)"

lemma sats_cond_of_fm :
  " x  nat; y  nat;env  list(A)  
     sats(A,cond_of_fm(x,y), env) 
        is_cond_of(##A, nth(x,env), nth(y,env))"
  unfolding cond_of_fm_def is_cond_of_def using sats_snd_fm sats_snd2_fm
    sats_hcomp_fm[of A "is_snd(##A)" _ snd_fm "is_snd_snd(##A)"] by simp

lemma is_cond_of_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "anat" "bnat" "env  list(A)"
  shows
    "is_cond_of(##A,aa,bb)   sats(A,cond_of_fm(a,b), env)"
  using assms
  by (simp add:sats_cond_of_fm)

lemma components_type[TC] :
  assumes "anat" "bnat"
  shows 
    "ftype_fm(a,b)formula" 
    "name1_fm(a,b)formula"
    "name2_fm(a,b)formula"
    "cond_of_fm(a,b)formula"
  using assms
  unfolding ftype_fm_def fst_fm_def snd_fm_def snd_snd_fm_def name1_fm_def name2_fm_def 
    cond_of_fm_def hcomp_fm_def
  by simp_all

lemmas sats_components_fm[simp] = sats_ftype_fm sats_name1_fm sats_name2_fm sats_cond_of_fm

lemmas components_iff_sats = is_ftype_iff_sats is_name1_iff_sats is_name2_iff_sats
  is_cond_of_iff_sats

lemmas components_defs = fst_fm_def ftype_fm_def snd_fm_def snd_snd_fm_def hcomp_fm_def
  name1_fm_def name2_fm_def cond_of_fm_def


definition
  is_eclose_n :: "[io,[io,i,i]o,i,i]  o" where
  "is_eclose_n(N,is_name,en,t)  
        n1[N].s1[N]. is_name(N,t,n1)  is_singleton(N,n1,s1)  is_eclose(N,s1,en)"

definition 
  eclose_n1_fm :: "[i,i]  i" where
  "eclose_n1_fm(m,t)  Exists(Exists(And(And(name1_fm(t#+2,0),singleton_fm(0,1)),
                                       is_eclose_fm(1,m#+2))))"

definition 
  eclose_n2_fm :: "[i,i]  i" where
  "eclose_n2_fm(m,t)  Exists(Exists(And(And(name2_fm(t#+2,0),singleton_fm(0,1)),
                                       is_eclose_fm(1,m#+2))))"

definition
  is_ecloseN :: "[io,i,i]  o" where
  "is_ecloseN(N,en,t)  en1[N].en2[N].
                is_eclose_n(N,is_name1,en1,t)  is_eclose_n(N,is_name2,en2,t)
                union(N,en1,en2,en)"

definition 
  ecloseN_fm :: "[i,i]  i" where
  "ecloseN_fm(en,t)  Exists(Exists(And(eclose_n1_fm(1,t#+2),
                            And(eclose_n2_fm(0,t#+2),union_fm(1,0,en#+2)))))"
lemma ecloseN_fm_type [TC] :
  " en  nat ; t  nat   ecloseN_fm(en,t)  formula"
  unfolding ecloseN_fm_def eclose_n1_fm_def eclose_n2_fm_def by simp

lemma sats_ecloseN_fm [simp]:
  " en  nat; t  nat ; env  list(A) 
     sats(A, ecloseN_fm(en,t), env)  is_ecloseN(##A,nth(en,env),nth(t,env))"
  unfolding ecloseN_fm_def is_ecloseN_def eclose_n1_fm_def eclose_n2_fm_def is_eclose_n_def
  using  nth_0 nth_ConsI sats_name1_fm sats_name2_fm 
    is_singleton_iff_sats[symmetric]
  by auto

(* Relation of forces *)
definition
  frecR :: "i  i  o" where
  "frecR(x,y) 
    (ftype(x) = 1  ftype(y) = 0 
       (name1(x)  domain(name1(y))  domain(name2(y))  (name2(x) = name1(y)  name2(x) = name2(y))))
    (ftype(x) = 0  ftype(y) =  1  name1(x) = name1(y)  name2(x)  domain(name2(y)))"

lemma frecR_ftypeD :
  assumes "frecR(x,y)"
  shows "(ftype(x) = 0  ftype(y) = 1)  (ftype(x) = 1  ftype(y) = 0)"
  using assms unfolding frecR_def by auto

lemma frecRI1: "s  domain(n1)  s  domain(n2)  frecR(1, s, n1, q, 0, n1, n2, q')"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI1': "s  domain(n1)  domain(n2)  frecR(1, s, n1, q, 0, n1, n2, q')"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI2: "s  domain(n1)  s  domain(n2)  frecR(1, s, n2, q, 0, n1, n2, q')"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI2': "s  domain(n1)  domain(n2)  frecR(1, s, n2, q, 0, n1, n2, q')"
  unfolding frecR_def by (simp add:components_simp)


lemma frecRI3: "s, r  n2  frecR(0, n1, s, q, 1, n1, n2, q')"
  unfolding frecR_def by (auto simp add:components_simp)

lemma frecRI3': "s  domain(n2)  frecR(0, n1, s, q, 1, n1, n2, q')"
  unfolding frecR_def by (auto simp add:components_simp)

lemma frecR_iff :
  "frecR(x,y) 
    (ftype(x) = 1  ftype(y) = 0 
       (name1(x)  domain(name1(y))  domain(name2(y))  (name2(x) = name1(y)  name2(x) = name2(y))))
    (ftype(x) = 0  ftype(y) =  1  name1(x) = name1(y)  name2(x)  domain(name2(y)))"
  unfolding frecR_def ..

lemma frecR_D1 :
  "frecR(x,y)  ftype(y) = 0  ftype(x) = 1  
      (name1(x)  domain(name1(y))  domain(name2(y))  (name2(x) = name1(y)  name2(x) = name2(y)))"
  using frecR_iff
  by auto

lemma frecR_D2 :
  "frecR(x,y)  ftype(y) = 1  ftype(x) = 0  
      ftype(x) = 0  ftype(y) =  1  name1(x) = name1(y)  name2(x)  domain(name2(y))"
  using frecR_iff
  by auto

lemma frecR_DI : 
  assumes "frecR(a,b,c,d,ftype(y),name1(y),name2(y),cond_of(y))"
  shows "frecR(a,b,c,d,y)"
  using assms unfolding frecR_def by (force simp add:components_simp)

(*
name1(x) ∈ domain(name1(y)) ∪ domain(name2(y)) ∧ 
            (name2(x) = name1(y) ∨ name2(x) = name2(y)) 
          ∨ name1(x) = name1(y) ∧ name2(x) ∈ domain(name2(y))*)
definition
  is_frecR :: "[io,i,i]  o" where
  "is_frecR(M,x,y)   ftx[M].  n1x[M]. n2x[M]. fty[M]. n1y[M]. n2y[M]. dn1[M]. dn2[M].
  is_ftype(M,x,ftx)  is_name1(M,x,n1x) is_name2(M,x,n2x) 
  is_ftype(M,y,fty)  is_name1(M,y,n1y)  is_name2(M,y,n2y)
           is_domain(M,n1y,dn1)  is_domain(M,n2y,dn2)  
          (  (number1(M,ftx)  empty(M,fty)  (n1x  dn1  n1x  dn2)  (n2x = n1y  n2x = n2y))
            (empty(M,ftx)  number1(M,fty)  n1x = n1y  n2x  dn2))"

schematic_goal sats_frecR_fm_auto:
  assumes 
    "inat" "jnat" "envlist(A)" "nth(i,env) = a" "nth(j,env) = b"
  shows
    "is_frecR(##A,a,b)  sats(A,?fr_fm(i,j),env)"
  unfolding  is_frecR_def is_Collect_def  
  by (insert assms ; (rule sep_rules' cartprod_iff_sats  components_iff_sats
        | simp del:sats_cartprod_fm)+)

synthesize "frecR_fm" from_schematic sats_frecR_fm_auto

(* Third item of Kunen observations about the trcl relation in p. 257. *)
lemma eq_ftypep_not_frecrR:
  assumes "ftype(x) = ftype(y)"
  shows "¬ frecR(x,y)"
  using assms frecR_ftypeD by force


definition
  rank_names :: "i  i" where
  "rank_names(x)  max(rank(name1(x)),rank(name2(x)))"

lemma rank_names_types [TC]: 
  shows "Ord(rank_names(x))"
  unfolding rank_names_def max_def using Ord_rank Ord_Un by auto

definition
  mtype_form :: "i  i" where
  "mtype_form(x)  if rank(name1(x)) < rank(name2(x)) then 0 else 2"

definition
  type_form :: "i  i" where
  "type_form(x)  if ftype(x) = 0 then 1 else mtype_form(x)"

lemma type_form_tc [TC]: 
  shows "type_form(x)  3"
  unfolding type_form_def mtype_form_def by auto

lemma frecR_le_rnk_names :
  assumes  "frecR(x,y)"
  shows "rank_names(x)rank_names(y)"
proof -
  obtain a b c d  where
    H: "a = name1(x)" "b = name2(x)"
    "c = name1(y)" "d = name2(y)"
    "(a  domain(c)domain(d)  (b=c  b = d))  (a = c  b  domain(d))"
    using assms unfolding frecR_def by force
  then 
  consider
    (m) "a  domain(c)  (b = c  b = d) "
    | (n) "a  domain(d)  (b = c  b = d)" 
    | (o) "b  domain(d)  a = c"
    by auto
  then show ?thesis proof(cases)
    case m
    then 
    have "rank(a) < rank(c)" 
      using eclose_rank_lt  in_dom_in_eclose  by simp
    with ‹rank(a) < rank(c) H m
    show ?thesis unfolding rank_names_def using Ord_rank max_cong max_cong2 leI by auto
  next
    case n
    then
    have "rank(a) < rank(d)"
      using eclose_rank_lt in_dom_in_eclose  by simp
    with ‹rank(a) < rank(d) H n
    show ?thesis unfolding rank_names_def 
      using Ord_rank max_cong2 max_cong max_commutes[of "rank(c)" "rank(d)"] leI by auto
  next
    case o
    then
    have "rank(b) < rank(d)" (is "?b < ?d") "rank(a) = rank(c)" (is "?a = _")
      using eclose_rank_lt in_dom_in_eclose  by simp_all
    with H
    show ?thesis unfolding rank_names_def
      using Ord_rank max_commutes max_cong2[OF leI[OF ?b < ?d], of ?a] by simp
  qed
qed


definition 
  Γ :: "i  i" where
  "Γ(x) = 3 ** rank_names(x) ++ type_form(x)"

lemma Γ_type [TC]: 
  shows "Ord(Γ(x))"
  unfolding Γ_def by simp


lemma Γ_mono : 
  assumes "frecR(x,y)"
  shows (x) < Γ(y)"
proof -
  have F: "type_form(x) < 3" "type_form(y) < 3"
    using ltI by simp_all
  from assms 
  have A: "rank_names(x)  rank_names(y)" (is "?x  ?y")
    using frecR_le_rnk_names by simp
  then
  have "Ord(?y)" unfolding rank_names_def using Ord_rank max_def by simp
  note leE[OF ?x?y] 
  then
  show ?thesis
  proof(cases)
    case 1
    then 
    show ?thesis unfolding Γ_def using oadd_lt_mono2 ?x < ?y F by auto
  next
    case 2
    consider (a) "ftype(x) = 0  ftype(y) = 1" | (b) "ftype(x) = 1  ftype(y) = 0"
      using  frecR_ftypeD[OF ‹frecR(x,y)] by auto
    then show ?thesis proof(cases)
      case b
      then 
      have "type_form(y) = 1" 
        using type_form_def by simp
      from b
      have H: "name2(x) = name1(y)  name2(x) = name2(y) " (is " = ?σ'   = ?τ'")
        "name1(x)  domain(name1(y))  domain(name2(y))" 
        (is "  domain(?σ')  domain(?τ')")
        using assms unfolding type_form_def frecR_def by auto
      then 
      have E: "rank() = rank(?σ')  rank() = rank(?τ')" by auto
      from H
      consider (a) "rank() < rank(?σ')" |  (b) "rank() < rank(?τ')"
        using eclose_rank_lt in_dom_in_eclose by force
      then
      have "rank() < rank()" proof (cases)
        case a
        with ‹rank_names(x) = rank_names(y)
        show ?thesis unfolding rank_names_def mtype_form_def type_form_def using max_D2[OF E a]
            E assms Ord_rank by simp
      next
        case b
        with ‹rank_names(x) = rank_names(y)
        show ?thesis unfolding rank_names_def mtype_form_def type_form_def 
          using max_D2[OF _ b] max_commutes E assms Ord_rank disj_commute by auto
      qed
      with b
      have "type_form(x) = 0" unfolding type_form_def mtype_form_def by simp
      with ‹rank_names(x) = rank_names(y) ‹type_form(y) = 1 ‹type_form(x) = 0
      show ?thesis 
        unfolding Γ_def by auto
    next
      case a
      then 
      have "name1(x) = name1(y)" (is " = ?σ'") 
        "name2(x)  domain(name2(y))" (is "  domain(?τ')")
        "type_form(x) = 1"
        using assms unfolding type_form_def frecR_def by auto
      then
      have "rank() = rank(?σ')" "rank() < rank(?τ')" 
        using  eclose_rank_lt in_dom_in_eclose by simp_all
      with ‹rank_names(x) = rank_names(y) 
      have "rank(?τ')  rank(?σ')" 
        unfolding rank_names_def using Ord_rank max_D1 by simp
      with a
      have "type_form(y) = 2"
        unfolding type_form_def mtype_form_def using not_lt_iff_le assms by simp
      with ‹rank_names(x) = rank_names(y) ‹type_form(y) = 2 ‹type_form(x) = 1
      show ?thesis 
        unfolding Γ_def by auto
    qed
  qed
qed

definition
  frecrel :: "i  i" where
  "frecrel(A)  Rrel(frecR,A)"

lemma frecrelI : 
  assumes "x  A" "yA" "frecR(x,y)"
  shows "x,yfrecrel(A)"
  using assms unfolding frecrel_def Rrel_def by auto

lemma frecrelD :
  assumes "x,y  frecrel(A1×A2×A3×A4)"
  shows "ftype(x)  A1" "ftype(x)  A1"
    "name1(x)  A2" "name1(y)  A2" "name2(x)  A3" "name2(x)  A3" 
    "cond_of(x)  A4" "cond_of(y)  A4" 
    "frecR(x,y)"
  using assms unfolding frecrel_def Rrel_def ftype_def by (auto simp add:components_simp)

lemma wf_frecrel : 
  shows "wf(frecrel(A))"
proof -
  have "frecrel(A)  measure(A,Γ)"
    unfolding frecrel_def Rrel_def measure_def
    using Γ_mono by force
  then show ?thesis using wf_subset wf_measure by auto
qed

lemma core_induction_aux:
  fixes A1 A2 :: "i"
  assumes
    "Transset(A1)"
    "τ θ p.  p  A2  q σ.  qA2 ; σdomain(θ)  Q(0,τ,σ,q)  Q(1,τ,θ,p)"
    "τ θ p.  p  A2  q σ.  qA2 ; σdomain(τ)  domain(θ)  Q(1,σ,τ,q)  Q(1,σ,θ,q)  Q(0,τ,θ,p)"
  shows "a2×A1×A1×A2  Q(ftype(a),name1(a),name2(a),cond_of(a))"
proof (induct a rule:wf_induct[OF wf_frecrel[of "2×A1×A1×A2"]])
  case (1 x)
  let  = "name1(x)" 
  let  = "name2(x)"
  let ?D = "2×A1×A1×A2"
  assume "x  ?D"
  then
  have "cond_of(x)A2" 
    by (auto simp add:components_simp)
  from x?D
  consider (eq) "ftype(x)=0" | (mem) "ftype(x)=1"
    by (auto simp add:components_simp)
  then 
  show ?case 
  proof cases
    case eq
    then 
    have "Q(1, σ, , q)  Q(1, σ, , q)" if "σ  domain()  domain()" and "qA2" for q σ
    proof -
      from 1
      have A: "A1" "A1" "eclose(A1)" "eclose(A1)"
        using  arg_into_eclose by (auto simp add:components_simp)
      with  ‹Transset(A1) that(1)
      have "σeclose()  eclose()" 
        using in_dom_in_eclose  by auto
      then
      have "σA1"
        using mem_eclose_subset[OF A1] mem_eclose_subset[OF A1] 
          Transset_eclose_eq_arg[OF ‹Transset(A1)] 
        by auto         
      with qA2   A1 ‹cond_of(x)A2 A1
      have "frecR(1, σ, , q, x)" (is "frecR(?T,_)")
        "frecR(1, σ, , q, x)" (is "frecR(?U,_)")
        using  frecRI1'[OF that(1)] frecR_DI  ‹ftype(x) = 0 
          frecRI2'[OF that(1)] 
        by (auto simp add:components_simp)
      with x?D σA1 qA2
      have "?T,x frecrel(?D)" "?U,x frecrel(?D)" 
        using frecrelI[of ?T ?D x]  frecrelI[of ?U ?D x] by (auto simp add:components_simp)
      with qA2 σA1 A1 A1
      have "Q(1, σ, , q)" using 1 by (force simp add:components_simp)
      moreover from qA2 σA1 A1 A1 ?U,x frecrel(?D)
      have "Q(1, σ, , q)" using 1 by (force simp add:components_simp)
      ultimately
      show ?thesis using A by simp
    qed
    then show ?thesis using assms(3) ‹ftype(x) = 0 ‹cond_of(x)A2 by auto
  next
    case mem
    have "Q(0, ,  σ, q)" if "σ  domain()" and "qA2" for q σ
    proof -
      from 1 assms
      have "A1" "A1" "cond_of(x)A2" "eclose(A1)" "eclose(A1)"
        using  arg_into_eclose by (auto simp add:components_simp)
      with  ‹Transset(A1) that(1)
      have "σ eclose()" 
        using in_dom_in_eclose  by auto
      then
      have "σA1"
        using mem_eclose_subset[OF A1] Transset_eclose_eq_arg[OF ‹Transset(A1)] 
        by auto         
      with qA2   A1 ‹cond_of(x)A2 A1
      have "frecR(0, , σ, q, x)" (is "frecR(?T,_)")
        using  frecRI3'[OF that(1)] frecR_DI  ‹ftype(x) = 1                 
        by (auto simp add:components_simp)
      with x?D σA1 qA2 A1
      have "?T,x frecrel(?D)" "?T?D"
        using frecrelI[of ?T ?D x] by (auto simp add:components_simp)
      with qA2 σA1 A1 A1 1
      show ?thesis by (force simp add:components_simp)
    qed
    then show ?thesis using assms(2) ‹ftype(x) = 1 ‹cond_of(x)A2  by auto
  qed
qed

lemma def_frecrel : "frecrel(A) = {zA×A. x y. z = x, y  frecR(x,y)}"
  unfolding frecrel_def Rrel_def ..

lemma frecrel_fst_snd:
  "frecrel(A) = {z  A×A . 
            ftype(fst(z)) = 1  
        ftype(snd(z)) = 0  name1(fst(z))  domain(name1(snd(z)))  domain(name2(snd(z)))  
            (name2(fst(z)) = name1(snd(z))  name2(fst(z)) = name2(snd(z))) 
           (ftype(fst(z)) = 0  
        ftype(snd(z)) = 1   name1(fst(z)) = name1(snd(z))  name2(fst(z))  domain(name2(snd(z))))}"
  unfolding def_frecrel frecR_def
  by (intro equalityI subsetI CollectI; elim CollectE; auto)

end

Theory Arities

section‹Arities of internalized formulas›
theory Arities
  imports FrecR
begin

lemma arity_upair_fm : "  t1nat ; t2nat ; upnat    
  arity(upair_fm(t1,t2,up)) =  {succ(t1),succ(t2),succ(up)}"
  unfolding  upair_fm_def
  using nat_union_abs1 nat_union_abs2 pred_Un   
  by auto


lemma arity_pair_fm : "  t1nat ; t2nat ; pnat    
  arity(pair_fm(t1,t2,p)) =  {succ(t1),succ(t2),succ(p)}"
  unfolding pair_fm_def 
  using arity_upair_fm nat_union_abs1 nat_union_abs2 pred_Un
  by auto

lemma arity_composition_fm :
  " rnat ; snat ; tnat   arity(composition_fm(r,s,t)) =  {succ(r), succ(s), succ(t)}"
  unfolding composition_fm_def    
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_domain_fm : 
    " rnat ; znat   arity(domain_fm(r,z)) = succ(r)  succ(z)"
  unfolding domain_fm_def 
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_range_fm : 
    " rnat ; znat   arity(range_fm(r,z)) = succ(r)  succ(z)"
  unfolding range_fm_def 
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_union_fm : 
  " xnat ; ynat ; znat   arity(union_fm(x,y,z)) =  {succ(x), succ(y), succ(z)}"
  unfolding union_fm_def
  using  nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_image_fm : 
  " xnat ; ynat ; znat   arity(image_fm(x,y,z)) =  {succ(x), succ(y), succ(z)}"
  unfolding image_fm_def
  using arity_pair_fm  nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_pre_image_fm : 
  " xnat ; ynat ; znat   arity(pre_image_fm(x,y,z)) =  {succ(x), succ(y), succ(z)}"
  unfolding pre_image_fm_def
  using arity_pair_fm  nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto


lemma arity_big_union_fm : 
  " xnat ; ynat   arity(big_union_fm(x,y)) = succ(x)  succ(y)"
  unfolding big_union_fm_def
  using nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_fun_apply_fm : 
  " xnat ; ynat ; fnat   
    arity(fun_apply_fm(f,x,y)) =  succ(f)  succ(x)  succ(y)"
  unfolding fun_apply_fm_def
  using arity_upair_fm arity_image_fm arity_big_union_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_field_fm : 
    " rnat ; znat   arity(field_fm(r,z)) = succ(r)  succ(z)"
  unfolding field_fm_def 
  using arity_pair_fm arity_domain_fm arity_range_fm arity_union_fm 
    nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_empty_fm : 
    " rnat   arity(empty_fm(r)) = succ(r)"
  unfolding empty_fm_def 
  using nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp

lemma arity_succ_fm :
  "xnat;ynat  arity(succ_fm(x,y)) = succ(x)  succ(y)"
  unfolding succ_fm_def cons_fm_def 
  using arity_upair_fm arity_union_fm nat_union_abs2 pred_Un_distrib
  by auto


lemma number1arity__fm : 
    " rnat   arity(number1_fm(r)) = succ(r)"
  unfolding number1_fm_def 
  using arity_empty_fm arity_succ_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp


lemma arity_function_fm : 
    " rnat   arity(function_fm(r)) = succ(r)"
  unfolding function_fm_def 
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp

lemma arity_relation_fm : 
    " rnat   arity(relation_fm(r)) = succ(r)"
  unfolding relation_fm_def 
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp

lemma arity_restriction_fm : 
    " rnat ; znat ; Anat   arity(restriction_fm(A,z,r)) = succ(A)  succ(r)  succ(z)"
  unfolding restriction_fm_def 
  using arity_pair_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_typed_function_fm : 
  " xnat ; ynat ; fnat   
    arity(typed_function_fm(f,x,y)) =  {succ(f), succ(x), succ(y)}"
  unfolding typed_function_fm_def
  using arity_pair_fm arity_relation_fm arity_function_fm arity_domain_fm 
    nat_union_abs2 pred_Un_distrib
  by auto


lemma arity_subset_fm : 
  "xnat ; ynat  arity(subset_fm(x,y)) = succ(x)  succ(y)"
  unfolding subset_fm_def 
  using nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_transset_fm :
  "xnat  arity(transset_fm(x)) = succ(x)"
  unfolding transset_fm_def 
  using arity_subset_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_ordinal_fm :
  "xnat  arity(ordinal_fm(x)) = succ(x)"
  unfolding ordinal_fm_def 
  using arity_transset_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_limit_ordinal_fm :
  "xnat  arity(limit_ordinal_fm(x)) = succ(x)"
  unfolding limit_ordinal_fm_def 
  using arity_ordinal_fm arity_succ_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_finite_ordinal_fm :
  "xnat  arity(finite_ordinal_fm(x)) = succ(x)"
  unfolding finite_ordinal_fm_def 
  using arity_ordinal_fm arity_limit_ordinal_fm arity_succ_fm arity_empty_fm 
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_omega_fm :
  "xnat  arity(omega_fm(x)) = succ(x)"
  unfolding omega_fm_def 
  using arity_limit_ordinal_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_cartprod_fm : 
  " Anat ; Bnat ; znat   arity(cartprod_fm(A,B,z)) = succ(A)  succ(B)  succ(z)"
  unfolding cartprod_fm_def
  using arity_pair_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_fst_fm :
  "xnat ; tnat  arity(fst_fm(x,t)) = succ(x)  succ(t)"
  unfolding fst_fm_def
  using arity_pair_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_snd_fm :
  "xnat ; tnat  arity(snd_fm(x,t)) = succ(x)  succ(t)"
  unfolding snd_fm_def
  using arity_pair_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_snd_snd_fm :
  "xnat ; tnat  arity(snd_snd_fm(x,t)) = succ(x)  succ(t)"
  unfolding snd_snd_fm_def hcomp_fm_def
  using arity_snd_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_ftype_fm :
  "xnat ; tnat  arity(ftype_fm(x,t)) = succ(x)  succ(t)"
  unfolding ftype_fm_def
  using arity_fst_fm 
  by auto

lemma name1arity__fm :
  "xnat ; tnat  arity(name1_fm(x,t)) = succ(x)  succ(t)"
  unfolding name1_fm_def hcomp_fm_def
  using arity_fst_fm arity_snd_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma name2arity__fm :
  "xnat ; tnat  arity(name2_fm(x,t)) = succ(x)  succ(t)"
  unfolding name2_fm_def hcomp_fm_def
  using arity_fst_fm arity_snd_snd_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_cond_of_fm :
  "xnat ; tnat  arity(cond_of_fm(x,t)) = succ(x)  succ(t)"
  unfolding cond_of_fm_def hcomp_fm_def
  using arity_snd_fm arity_snd_snd_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_singleton_fm :
  "xnat ; tnat  arity(singleton_fm(x,t)) = succ(x)  succ(t)"
  unfolding singleton_fm_def cons_fm_def
  using arity_union_fm arity_upair_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_Memrel_fm :
  "xnat ; tnat  arity(Memrel_fm(x,t)) = succ(x)  succ(t)"
  unfolding Memrel_fm_def 
  using  arity_pair_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_quasinat_fm :
  "xnat  arity(quasinat_fm(x)) = succ(x)"
  unfolding quasinat_fm_def cons_fm_def 
  using arity_succ_fm arity_empty_fm
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_is_recfun_fm :
  "pformula ; vnat ; nnat; Znat;inat   arity(p) = i  
  arity(is_recfun_fm(p,v,n,Z)) = succ(v)  succ(n)  succ(Z)  pred(pred(pred(pred(i))))"
  unfolding is_recfun_fm_def
  using arity_upair_fm arity_pair_fm arity_pre_image_fm arity_restriction_fm
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_is_wfrec_fm :
  "pformula ; vnat ; nnat; Znat ; inat  arity(p) = i  
    arity(is_wfrec_fm(p,v,n,Z)) = succ(v)  succ(n)  succ(Z)  pred(pred(pred(pred(pred(i)))))"
  unfolding is_wfrec_fm_def
  using arity_succ_fm  arity_is_recfun_fm 
     nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_is_nat_case_fm :
  "pformula ; vnat ; nnat; Znat; inat  arity(p) = i  
    arity(is_nat_case_fm(v,p,n,Z)) = succ(v)  succ(n)  succ(Z)  pred(pred(i))"
  unfolding is_nat_case_fm_def
  using arity_succ_fm arity_empty_fm arity_quasinat_fm 
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_iterates_MH_fm :
  assumes "isFformula" "vnat" "nnat" "gnat" "znat" "inat" 
      "arity(isF) = i"
    shows "arity(iterates_MH_fm(isF,v,n,g,z)) = 
           succ(v)  succ(n)  succ(g)  succ(z)  pred(pred(pred(pred(i))))"
proof -
  let  = "Exists(And(fun_apply_fm(succ(succ(succ(g))), 2, 0), Forall(Implies(Equal(0, 2), isF))))"
  let ?ar = "succ(succ(succ(g)))  pred(pred(i))"
  from assms
  have "arity() =?ar" "formula" 
    using arity_fun_apply_fm
    nat_union_abs1 nat_union_abs2 pred_Un_distrib succ_Un_distrib Un_assoc[symmetric]
    by simp_all
  then
  show ?thesis
    unfolding iterates_MH_fm_def
    using arity_is_nat_case_fm[OF _ _ _ _ _ ‹arity() = _] assms pred_succ_eq pred_Un_distrib
    by auto
qed

lemma arity_is_iterates_fm :
  assumes "pformula" "vnat" "nnat" "Znat" "inat" 
    "arity(p) = i"
  shows "arity(is_iterates_fm(p,v,n,Z)) = succ(v)  succ(n)  succ(Z)  
          pred(pred(pred(pred(pred(pred(pred(pred(pred(pred(pred(i)))))))))))"
proof -
  let  = "iterates_MH_fm(p, 7#+v, 2, 1, 0)"
  let  = "is_wfrec_fm(, 0, succ(succ(n)),succ(succ(Z)))"
  from v_
  have "arity() = (8#+v)  pred(pred(pred(pred(i))))" "formula"
    using assms arity_iterates_MH_fm nat_union_abs2
    by simp_all
  then
  have "arity() = succ(succ(succ(n)))  succ(succ(succ(Z)))  (3#+v)  
      pred(pred(pred(pred(pred(pred(pred(pred(pred(i)))))))))"
    using assms arity_is_wfrec_fm[OF _ _ _ _ _ ‹arity() = _] nat_union_abs1 pred_Un_distrib
    by auto
  then
  show ?thesis
    unfolding is_iterates_fm_def 
    using arity_Memrel_fm arity_succ_fm assms nat_union_abs1 pred_Un_distrib
    by auto
qed

lemma arity_eclose_n_fm :
  assumes "Anat" "xnat" "tnat" 
  shows "arity(eclose_n_fm(A,x,t)) = succ(A)  succ(x)  succ(t)"
proof -
  let  = "big_union_fm(1,0)"
  have "arity() = 2" "formula" 
    using arity_big_union_fm nat_union_abs2
    by simp_all
  with assms
  show ?thesis
    unfolding eclose_n_fm_def
    using arity_is_iterates_fm[OF _ _ _ _,of _ _ _ 2] 
    by auto
qed

lemma arity_mem_eclose_fm :
  assumes "xnat" "tnat"
  shows "arity(mem_eclose_fm(x,t)) = succ(x)  succ(t)"
proof -  
  let ="eclose_n_fm(x #+ 2, 1, 0)"
  from xnat›
  have "arity() = x#+3" 
    using arity_eclose_n_fm nat_union_abs2 
    by simp
  with assms
  show ?thesis
    unfolding mem_eclose_fm_def 
    using arity_finite_ordinal_fm nat_union_abs2 pred_Un_distrib
    by simp
qed

lemma arity_is_eclose_fm :
  "xnat ; tnat  arity(is_eclose_fm(x,t)) = succ(x)  succ(t)"
  unfolding is_eclose_fm_def 
  using arity_mem_eclose_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma eclose_n1arity__fm :
  "xnat ; tnat  arity(eclose_n1_fm(x,t)) = succ(x)  succ(t)"
  unfolding eclose_n1_fm_def 
  using arity_is_eclose_fm arity_singleton_fm name1arity__fm nat_union_abs2 pred_Un_distrib
  by auto

lemma eclose_n2arity__fm :
  "xnat ; tnat  arity(eclose_n2_fm(x,t)) = succ(x)  succ(t)"
  unfolding eclose_n2_fm_def 
  using arity_is_eclose_fm arity_singleton_fm name2arity__fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_ecloseN_fm :
  "xnat ; tnat  arity(ecloseN_fm(x,t)) = succ(x)  succ(t)"
  unfolding ecloseN_fm_def 
  using eclose_n1arity__fm eclose_n2arity__fm arity_union_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_frecR_fm :
  "anat;bnat  arity(frecR_fm(a,b)) = succ(a)  succ(b)"
  unfolding frecR_fm_def
  using arity_ftype_fm name1arity__fm name2arity__fm arity_domain_fm 
      number1arity__fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_Collect_fm :
  assumes "x  nat" "y  nat" "pformula" 
  shows "arity(Collect_fm(x,p,y)) = succ(x)  succ(y)  pred(arity(p))"
  unfolding Collect_fm_def
  using assms pred_Un_distrib
  by auto

end

Theory Forces_Definition

section‹The definition of termforces
theory Forces_Definition imports Arities FrecR Synthetic_Definition begin

text‹This is the core of our development.›

subsection‹The relation term‹frecrel›

definition
  frecrelP :: "[io,i]  o" where
  "frecrelP(M,xy)  (x[M]. y[M]. pair(M,x,y,xy)  is_frecR(M,x,y))"

definition
  frecrelP_fm :: "i  i" where
  "frecrelP_fm(a)  Exists(Exists(And(pair_fm(1,0,a#+2),frecR_fm(1,0))))"

lemma arity_frecrelP_fm :
  "anat  arity(frecrelP_fm(a)) = succ(a)"
  unfolding frecrelP_fm_def
  using arity_frecR_fm arity_pair_fm pred_Un_distrib
  by simp

lemma frecrelP_fm_type[TC] :
  "anat  frecrelP_fm(a)formula"
  unfolding frecrelP_fm_def by simp

lemma sats_frecrelP_fm :
  assumes "anat" "envlist(A)"
  shows "sats(A,frecrelP_fm(a),env)  frecrelP(##A,nth(a, env))"
  unfolding frecrelP_def frecrelP_fm_def
  using assms by (auto simp add:frecR_fm_iff_sats[symmetric])

lemma frecrelP_iff_sats:
  assumes
    "nth(a,env) = aa" "a nat"  "env  list(A)"
  shows
    "frecrelP(##A,aa)   sats(A, frecrelP_fm(a), env)"
  using assms
  by (simp add:sats_frecrelP_fm)

definition
  is_frecrel :: "[io,i,i]  o" where
  "is_frecrel(M,A,r)  A2[M]. cartprod(M,A,A,A2)  is_Collect(M,A2, frecrelP(M) ,r)"

definition
  frecrel_fm :: "[i,i]  i" where
  "frecrel_fm(a,r)  Exists(And(cartprod_fm(a#+1,a#+1,0),Collect_fm(0,frecrelP_fm(0),r#+1)))"

lemma frecrel_fm_type[TC] :
  "anat;bnat  frecrel_fm(a,b)formula"
  unfolding frecrel_fm_def by simp

lemma arity_frecrel_fm :
  assumes "anat"  "bnat"
  shows "arity(frecrel_fm(a,b)) = succ(a)  succ(b)"
  unfolding frecrel_fm_def
  using assms arity_Collect_fm arity_cartprod_fm arity_frecrelP_fm pred_Un_distrib
  by auto

lemma sats_frecrel_fm :
  assumes
    "anat"  "rnat" "envlist(A)"
  shows
    "sats(A,frecrel_fm(a,r),env)
     is_frecrel(##A,nth(a, env),nth(r, env))"
  unfolding is_frecrel_def frecrel_fm_def
  using assms
  by (simp add:sats_Collect_fm sats_frecrelP_fm)

lemma is_frecrel_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(r,env) = rr" "a nat"  "r nat"  "env  list(A)"
  shows
    "is_frecrel(##A, aa,rr)  sats(A, frecrel_fm(a,r), env)"
  using assms
  by (simp add:sats_frecrel_fm)

definition
  names_below :: "i  i  i" where
  "names_below(P,x)  2×ecloseN(x)×ecloseN(x)×P"

lemma names_belowsD:
  assumes "x  names_below(P,z)"
  obtains f n1 n2 p where
    "x = f,n1,n2,p" "f2" "n1ecloseN(z)" "n2ecloseN(z)" "pP"
  using assms unfolding names_below_def by auto


definition
  is_names_below :: "[io,i,i,i]  o" where
  "is_names_below(M,P,x,nb)  p1[M]. p0[M]. t[M]. ec[M].
              is_ecloseN(M,ec,x)  number2(M,t)  cartprod(M,ec,P,p0)  cartprod(M,ec,p0,p1)
               cartprod(M,t,p1,nb)"

definition
  number2_fm :: "ii" where
  "number2_fm(a)  Exists(And(number1_fm(0), succ_fm(0,succ(a))))"

lemma number2_fm_type[TC] :
  "anat  number2_fm(a)  formula"
  unfolding number2_fm_def by simp

lemma number2arity__fm :
  "anat  arity(number2_fm(a)) = succ(a)"
  unfolding number2_fm_def
  using number1arity__fm arity_succ_fm nat_union_abs2 pred_Un_distrib
  by simp

lemma sats_number2_fm [simp]:
  " x  nat; env  list(A) 
     sats(A, number2_fm(x), env)  number2(##A, nth(x,env))"
  by (simp add: number2_fm_def number2_def)

definition
  is_names_below_fm :: "[i,i,i]  i" where
  "is_names_below_fm(P,x,nb)  Exists(Exists(Exists(Exists(
                    And(ecloseN_fm(0,x #+ 4),And(number2_fm(1),
                    And(cartprod_fm(0,P #+ 4,2),And(cartprod_fm(0,2,3),cartprod_fm(1,3,nb#+4)))))))))"

lemma arity_is_names_below_fm :
  "Pnat;xnat;nbnat  arity(is_names_below_fm(P,x,nb)) = succ(P)  succ(x)  succ(nb)"
  unfolding is_names_below_fm_def
  using arity_cartprod_fm number2arity__fm arity_ecloseN_fm nat_union_abs2 pred_Un_distrib
  by auto


lemma is_names_below_fm_type[TC]:
  "Pnat;xnat;nbnat  is_names_below_fm(P,x,nb)formula"
  unfolding is_names_below_fm_def by simp

lemma sats_is_names_below_fm :
  assumes
    "Pnat" "xnat" "nbnat" "envlist(A)"
  shows
    "sats(A,is_names_below_fm(P,x,nb),env)
     is_names_below(##A,nth(P, env),nth(x, env),nth(nb, env))"
  unfolding is_names_below_fm_def is_names_below_def using assms by simp

definition
  is_tuple :: "[io,i,i,i,i,i]  o" where
  "is_tuple(M,z,t1,t2,p,t)  t1t2p[M]. t2p[M]. pair(M,t2,p,t2p)  pair(M,t1,t2p,t1t2p) 
                                                  pair(M,z,t1t2p,t)"


definition
  is_tuple_fm :: "[i,i,i,i,i]  i" where
  "is_tuple_fm(z,t1,t2,p,tup) = Exists(Exists(And(pair_fm(t2 #+ 2,p #+ 2,0),
                      And(pair_fm(t1 #+ 2,0,1),pair_fm(z #+ 2,1,tup #+ 2)))))"


lemma arity_is_tuple_fm : " znat ; t1nat ; t2nat ; pnat ; tupnat  
  arity(is_tuple_fm(z,t1,t2,p,tup)) =  {succ(z),succ(t1),succ(t2),succ(p),succ(tup)}"
  unfolding is_tuple_fm_def
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma is_tuple_fm_type[TC] :
  "znat  t1nat  t2nat  pnat  tupnat  is_tuple_fm(z,t1,t2,p,tup)formula"
  unfolding is_tuple_fm_def by simp

lemma sats_is_tuple_fm :
  assumes
    "znat"  "t1nat" "t2nat" "pnat" "tupnat" "envlist(A)"
  shows
    "sats(A,is_tuple_fm(z,t1,t2,p,tup),env)
     is_tuple(##A,nth(z, env),nth(t1, env),nth(t2, env),nth(p, env),nth(tup, env))"
  unfolding is_tuple_def is_tuple_fm_def using assms by simp

lemma is_tuple_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "nth(c,env) = cc" "nth(d,env) = dd" "nth(e,env) = ee"
    "anat" "bnat" "cnat" "dnat" "enat"  "env  list(A)"
  shows
    "is_tuple(##A,aa,bb,cc,dd,ee)   sats(A, is_tuple_fm(a,b,c,d,e), env)"
  using assms by (simp add: sats_is_tuple_fm)

subsection‹Definition of termforces for equality and membership›

(* p ||- τ = θ ≡
  ∀σ. σ∈domain(τ) ∪ domain(θ) ⟶ (∀q∈P. ⟨q,p⟩∈leq ⟶ ((q ||- σ∈τ) ⟷ (q ||- σ∈θ)) ) *)
definition
  eq_case :: "[i,i,i,i,i,i]  o" where
  "eq_case(t1,t2,p,P,leq,f)  s. sdomain(t1)  domain(t2) 
      (q. qP  q,pleq  (f`1,s,t1,q=1   f`1,s,t2,q =1))"


definition
  is_eq_case :: "[io,i,i,i,i,i,i]  o" where
  "is_eq_case(M,t1,t2,p,P,leq,f) 
   s[M]. (d[M]. is_domain(M,t1,d)  sd)  (d[M]. is_domain(M,t2,d)  sd)
        (q[M]. qP  (qp[M]. pair(M,q,p,qp)  qpleq) 
            (ost1q[M]. ost2q[M]. o[M].  vf1[M]. vf2[M].
             is_tuple(M,o,s,t1,q,ost1q) 
             is_tuple(M,o,s,t2,q,ost2q)  number1(M,o) 
             fun_apply(M,f,ost1q,vf1)  fun_apply(M,f,ost2q,vf2) 
             (vf1 = o  vf2 = o)))"

(* p ||-
   π ∈ τ ≡ ∀v∈P. ⟨v,p⟩∈leq ⟶ (∃q∈P. ⟨q,v⟩∈leq ∧ (∃σ. ∃r∈P. ⟨σ,r⟩∈τ ∧ ⟨q,r⟩∈leq ∧  q ||- π = σ)) *)
definition
  mem_case :: "[i,i,i,i,i,i]  o" where
  "mem_case(t1,t2,p,P,leq,f)  vP. v,pleq 
    (q. s. r. rP  qP  q,vleq  s,r  t2  q,rleq   f`0,t1,s,q = 1)"

definition
  is_mem_case :: "[io,i,i,i,i,i,i]  o" where
  "is_mem_case(M,t1,t2,p,P,leq,f)  v[M]. vp[M]. vP  pair(M,v,p,vp)  vpleq 
    (q[M]. s[M]. r[M]. qv[M]. sr[M]. qr[M]. z[M]. zt1sq[M]. o[M].
     r P  qP  pair(M,q,v,qv)  pair(M,s,r,sr)  pair(M,q,r,qr) 
     empty(M,z)  is_tuple(M,z,t1,s,q,zt1sq) 
     number1(M,o)  qvleq  srt2  qrleq  fun_apply(M,f,zt1sq,o))"


schematic_goal sats_is_mem_case_fm_auto:
  assumes
    "n1nat" "n2nat" "pnat" "Pnat" "leqnat" "fnat" "envlist(A)"
  shows
    "is_mem_case(##A, nth(n1, env),nth(n2, env),nth(p, env),nth(P, env), nth(leq, env),nth(f,env))
     sats(A,?imc_fm(n1,n2,p,P,leq,f),env)"
  unfolding is_mem_case_def
  by (insert assms ; (rule sep_rules'  is_tuple_iff_sats | simp)+)


synthesize "mem_case_fm" from_schematic sats_is_mem_case_fm_auto

lemma arity_mem_case_fm :
  assumes
    "n1nat" "n2nat" "pnat" "Pnat" "leqnat" "fnat"
  shows
    "arity(mem_case_fm(n1,n2,p,P,leq,f)) =
    succ(n1)  succ(n2)  succ(p)  succ(P)  succ(leq)  succ(f)"
  unfolding mem_case_fm_def
  using assms arity_pair_fm arity_is_tuple_fm number1arity__fm arity_fun_apply_fm arity_empty_fm
    pred_Un_distrib
  by auto

schematic_goal sats_is_eq_case_fm_auto:
  assumes
    "n1nat" "n2nat" "pnat" "Pnat" "leqnat" "fnat" "envlist(A)"
  shows
    "is_eq_case(##A, nth(n1, env),nth(n2, env),nth(p, env),nth(P, env), nth(leq, env),nth(f,env))
     sats(A,?iec_fm(n1,n2,p,P,leq,f),env)"
  unfolding is_eq_case_def
  by (insert assms ; (rule sep_rules'  is_tuple_iff_sats | simp)+)

synthesize "eq_case_fm" from_schematic sats_is_eq_case_fm_auto

lemma arity_eq_case_fm :
  assumes
    "n1nat" "n2nat" "pnat" "Pnat" "leqnat" "fnat"
  shows
    "arity(eq_case_fm(n1,n2,p,P,leq,f)) =
    succ(n1)  succ(n2)  succ(p)  succ(P)  succ(leq)  succ(f)"
  unfolding eq_case_fm_def
  using assms arity_pair_fm arity_is_tuple_fm number1arity__fm arity_fun_apply_fm arity_empty_fm
    arity_domain_fm pred_Un_distrib
  by auto

definition
  Hfrc :: "[i,i,i,i]  o" where
  "Hfrc(P,leq,fnnc,f)  ft. n1. n2. c. cP  fnnc = ft,n1,n2,c 
     (  ft = 0   eq_case(n1,n2,c,P,leq,f)
       ft = 1  mem_case(n1,n2,c,P,leq,f))"

definition
  is_Hfrc :: "[io,i,i,i,i]  o" where
  "is_Hfrc(M,P,leq,fnnc,f) 
     ft[M]. n1[M]. n2[M]. co[M].
      coP  is_tuple(M,ft,n1,n2,co,fnnc) 
      (  (empty(M,ft)  is_eq_case(M,n1,n2,co,P,leq,f))
        (number1(M,ft)   is_mem_case(M,n1,n2,co,P,leq,f)))"

definition
  Hfrc_fm :: "[i,i,i,i]  i" where
  "Hfrc_fm(P,leq,fnnc,f) 
    Exists(Exists(Exists(Exists(
      And(Member(0,P #+ 4),And(is_tuple_fm(3,2,1,0,fnnc #+ 4),
      Or(And(empty_fm(3),eq_case_fm(2,1,0,P #+ 4,leq #+ 4,f #+ 4)),
         And(number1_fm(3),mem_case_fm(2,1,0,P #+ 4,leq #+ 4,f #+ 4)))))))))"

lemma Hfrc_fm_type[TC] :
  "Pnat;leqnat;fnncnat;fnat  Hfrc_fm(P,leq,fnnc,f)formula"
  unfolding Hfrc_fm_def by simp

lemma arity_Hfrc_fm :
  assumes
    "Pnat" "leqnat" "fnncnat" "fnat"
  shows
    "arity(Hfrc_fm(P,leq,fnnc,f)) = succ(P)  succ(leq)  succ(fnnc)  succ(f)"
  unfolding Hfrc_fm_def
  using assms arity_is_tuple_fm arity_mem_case_fm arity_eq_case_fm
    arity_empty_fm number1arity__fm pred_Un_distrib
  by auto

lemma sats_Hfrc_fm:
  assumes
    "Pnat" "leqnat" "fnncnat" "fnat" "envlist(A)"
  shows
    "sats(A,Hfrc_fm(P,leq,fnnc,f),env)
     is_Hfrc(##A,nth(P, env), nth(leq, env), nth(fnnc, env),nth(f, env))"
  unfolding is_Hfrc_def Hfrc_fm_def
  using assms  
  by (simp add: sats_is_tuple_fm eq_case_fm_iff_sats[symmetric] mem_case_fm_iff_sats[symmetric])

lemma Hfrc_iff_sats:
  assumes
    "Pnat" "leqnat" "fnncnat" "fnat" "envlist(A)"
    "nth(P,env) = PP"  "nth(leq,env) = lleq" "nth(fnnc,env) = ffnnc" "nth(f,env) = ff"
  shows
    "is_Hfrc(##A, PP, lleq,ffnnc,ff)
     sats(A,Hfrc_fm(P,leq,fnnc,f),env)"
  using assms
  by (simp add:sats_Hfrc_fm)

definition
  is_Hfrc_at :: "[io,i,i,i,i,i]  o" where
  "is_Hfrc_at(M,P,leq,fnnc,f,z) 
            (empty(M,z)  ¬ is_Hfrc(M,P,leq,fnnc,f))
           (number1(M,z)  is_Hfrc(M,P,leq,fnnc,f))"

definition
  Hfrc_at_fm :: "[i,i,i,i,i]  i" where
  "Hfrc_at_fm(P,leq,fnnc,f,z)  Or(And(empty_fm(z),Neg(Hfrc_fm(P,leq,fnnc,f))),
                                      And(number1_fm(z),Hfrc_fm(P,leq,fnnc,f)))"

lemma arity_Hfrc_at_fm :
  assumes
    "Pnat" "leqnat" "fnncnat" "fnat" "znat"
  shows
    "arity(Hfrc_at_fm(P,leq,fnnc,f,z)) = succ(P)  succ(leq)  succ(fnnc)  succ(f)  succ(z)"
  unfolding Hfrc_at_fm_def
  using assms arity_Hfrc_fm arity_empty_fm number1arity__fm pred_Un_distrib
  by auto


lemma Hfrc_at_fm_type[TC] :
  "Pnat;leqnat;fnncnat;fnat;znat  Hfrc_at_fm(P,leq,fnnc,f,z)formula"
  unfolding Hfrc_at_fm_def by simp

lemma sats_Hfrc_at_fm:
  assumes
    "Pnat" "leqnat" "fnncnat" "fnat" "znat" "envlist(A)"
  shows
    "sats(A,Hfrc_at_fm(P,leq,fnnc,f,z),env)
     is_Hfrc_at(##A,nth(P, env), nth(leq, env), nth(fnnc, env),nth(f, env),nth(z, env))"
  unfolding is_Hfrc_at_def Hfrc_at_fm_def using assms sats_Hfrc_fm
  by simp

lemma is_Hfrc_at_iff_sats:
  assumes
    "Pnat" "leqnat" "fnncnat" "fnat" "znat" "envlist(A)"
    "nth(P,env) = PP"  "nth(leq,env) = lleq" "nth(fnnc,env) = ffnnc"
    "nth(f,env) = ff" "nth(z,env) = zz"
  shows
    "is_Hfrc_at(##A, PP, lleq,ffnnc,ff,zz)
     sats(A,Hfrc_at_fm(P,leq,fnnc,f,z),env)"
  using assms by (simp add:sats_Hfrc_at_fm)

lemma arity_tran_closure_fm :
  "xnat;fnat  arity(trans_closure_fm(x,f)) = succ(x)  succ(f)"
  unfolding trans_closure_fm_def
  using arity_omega_fm arity_field_fm arity_typed_function_fm arity_pair_fm arity_empty_fm arity_fun_apply_fm
    arity_composition_fm arity_succ_fm nat_union_abs2 pred_Un_distrib 
  by auto

subsection‹The well-founded relation termforcerel
definition
  forcerel :: "i  i  i" where
  "forcerel(P,x)  frecrel(names_below(P,x))^+"

definition
  is_forcerel :: "[io,i,i,i]  o" where
  "is_forcerel(M,P,x,z)  r[M]. nb[M]. tran_closure(M,r,z) 
                        (is_names_below(M,P,x,nb)  is_frecrel(M,nb,r))"

definition
  forcerel_fm :: "i i  i  i" where
  "forcerel_fm(p,x,z)  Exists(Exists(And(trans_closure_fm(1, z#+2),
                                        And(is_names_below_fm(p#+2,x#+2,0),frecrel_fm(0,1)))))"

lemma arity_forcerel_fm:
  "pnat;xnat;znat  arity(forcerel_fm(p,x,z)) = succ(p)  succ(x)  succ(z)"
  unfolding forcerel_fm_def
  using arity_frecrel_fm arity_tran_closure_fm arity_is_names_below_fm pred_Un_distrib
  by auto

lemma forcerel_fm_type[TC]:
  "pnat;xnat;znat  forcerel_fm(p,x,z)formula"
  unfolding forcerel_fm_def by simp


lemma sats_forcerel_fm:
  assumes
    "pnat" "xnat"  "znat" "envlist(A)"
  shows
    "sats(A,forcerel_fm(p,x,z),env)  is_forcerel(##A,nth(p,env),nth(x, env),nth(z, env))"
proof -
  have "sats(A,trans_closure_fm(1,z #+ 2),Cons(nb,Cons(r,env))) 
        tran_closure(##A, r, nth(z, env))" if "rA" "nbA" for r nb
    using that assms trans_closure_fm_iff_sats[of 1 "[nb,r]@env" _ "z#+2",symmetric] by simp
  moreover
  have "sats(A, is_names_below_fm(succ(succ(p)), succ(succ(x)), 0), Cons(nb, Cons(r, env))) 
        is_names_below(##A, nth(p,env), nth(x, env), nb)"
    if "rA" "nbA" for nb r
    using assms that sats_is_names_below_fm[of "p #+ 2" "x #+ 2" 0 "[nb,r]@env"] by simp
  moreover
  have "sats(A, frecrel_fm(0, 1), Cons(nb, Cons(r, env))) 
        is_frecrel(##A, nb, r)"
    if "rA" "nbA" for r nb
    using assms that sats_frecrel_fm[of 0 1 "[nb,r]@env"] by simp
  ultimately
  show ?thesis using assms unfolding is_forcerel_def forcerel_fm_def by simp
qed

subsectiontermfrc_at, forcing for atomic formulas›
definition
  frc_at :: "[i,i,i]  i" where
  "frc_at(P,leq,fnnc)  wfrec(frecrel(names_below(P,fnnc)),fnnc,
                              λx f. bool_of_o(Hfrc(P,leq,x,f)))"

definition
  is_frc_at :: "[io,i,i,i,i]  o" where
  "is_frc_at(M,P,leq,x,z)  r[M]. is_forcerel(M,P,x,r) 
                                    is_wfrec(M,is_Hfrc_at(M,P,leq),r,x,z)"

definition
  frc_at_fm :: "[i,i,i,i]  i" where
  "frc_at_fm(p,l,x,z)  Exists(And(forcerel_fm(succ(p),succ(x),0),
          is_wfrec_fm(Hfrc_at_fm(6#+p,6#+l,2,1,0),0,succ(x),succ(z))))"

lemma frc_at_fm_type [TC] :
  "pnat;lnat;xnat;znat  frc_at_fm(p,l,x,z)formula"
  unfolding frc_at_fm_def by simp

lemma arity_frc_at_fm :
  assumes "pnat" "lnat" "xnat" "znat"
  shows "arity(frc_at_fm(p,l,x,z)) = succ(p)  succ(l)  succ(x)  succ(z)"
proof -
  let  = "Hfrc_at_fm(6 #+ p, 6 #+ l, 2, 1, 0)"
  from assms
  have  "arity() = (7#+p)  (7#+l)" "  formula"
    using arity_Hfrc_at_fm nat_simp_union
    by auto
  with assms
  have W: "arity(is_wfrec_fm(, 0, succ(x), succ(z))) = 2#+p  (2#+l)  (2#+x)  (2#+z)"
    using arity_is_wfrec_fm[OF _ _ _ _ _ ‹arity() = _] pred_Un_distrib pred_succ_eq
      nat_union_abs1
    by auto
  from assms
  have "arity(forcerel_fm(succ(p),succ(x),0)) = succ(succ(p))  succ(succ(x))"
    using arity_forcerel_fm nat_simp_union
    by auto
  with W assms
  show ?thesis
    unfolding frc_at_fm_def
    using arity_forcerel_fm pred_Un_distrib
    by auto
qed

lemma sats_frc_at_fm :
  assumes
    "pnat" "lnat" "inat" "jnat" "envlist(A)" "i < length(env)" "j < length(env)"
  shows
    "sats(A,frc_at_fm(p,l,i,j),env) 
     is_frc_at(##A,nth(p,env),nth(l,env),nth(i,env),nth(j,env))"
proof -
  {
    fix r pp ll
    assume "rA"
    have 0:"is_Hfrc_at(##A,nth(p,env),nth(l,env),a2, a1, a0) 
         sats(A, Hfrc_at_fm(6#+p,6#+l,2,1,0), [a0,a1,a2,a3,a4,r]@env)"
      if "a0A" "a1A" "a2A" "a3A" "a4A" for a0 a1 a2 a3 a4
      using  that assms rA
        is_Hfrc_at_iff_sats[of "6#+p" "6#+l" 2 1 0 "[a0,a1,a2,a3,a4,r]@env" A]  by simp
    have "sats(A,is_wfrec_fm(Hfrc_at_fm(6 #+ p, 6 #+ l, 2, 1, 0), 0, succ(i), succ(j)),[r]@env) 
         is_wfrec(##A, is_Hfrc_at(##A, nth(p,env), nth(l,env)), r,nth(i, env), nth(j, env))"
      using assms rA
        sats_is_wfrec_fm[OF 0[simplified]]
      by simp
  }
  moreover
  have "sats(A, forcerel_fm(succ(p), succ(i), 0), Cons(r, env)) 
        is_forcerel(##A,nth(p,env),nth(i,env),r)" if "rA" for r
    using assms sats_forcerel_fm that by simp
  ultimately
  show ?thesis unfolding is_frc_at_def frc_at_fm_def
    using assms by simp
qed

definition
  forces_eq' :: "[i,i,i,i,i]  o" where
  "forces_eq'(P,l,p,t1,t2)  frc_at(P,l,0,t1,t2,p) = 1"

definition
  forces_mem' :: "[i,i,i,i,i]  o" where
  "forces_mem'(P,l,p,t1,t2)  frc_at(P,l,1,t1,t2,p) = 1"

definition
  forces_neq' :: "[i,i,i,i,i]  o" where
  "forces_neq'(P,l,p,t1,t2)  ¬ (qP. q,pl  forces_eq'(P,l,q,t1,t2))"

definition
  forces_nmem' :: "[i,i,i,i,i]  o" where
  "forces_nmem'(P,l,p,t1,t2)  ¬ (qP. q,pl  forces_mem'(P,l,q,t1,t2))"

definition
  is_forces_eq' :: "[io,i,i,i,i,i]  o" where
  "is_forces_eq'(M,P,l,p,t1,t2)  o[M]. z[M]. t[M]. number1(M,o)  empty(M,z) 
                                is_tuple(M,z,t1,t2,p,t)  is_frc_at(M,P,l,t,o)"

definition
  is_forces_mem' :: "[io,i,i,i,i,i]  o" where
  "is_forces_mem'(M,P,l,p,t1,t2)  o[M]. t[M]. number1(M,o) 
                                is_tuple(M,o,t1,t2,p,t)  is_frc_at(M,P,l,t,o)"

definition
  is_forces_neq' :: "[io,i,i,i,i,i]  o" where
  "is_forces_neq'(M,P,l,p,t1,t2) 
      ¬ (q[M]. qP  (qp[M]. pair(M,q,p,qp)  qpl  is_forces_eq'(M,P,l,q,t1,t2)))"

definition
  is_forces_nmem' :: "[io,i,i,i,i,i]  o" where
  "is_forces_nmem'(M,P,l,p,t1,t2) 
      ¬ (q[M]. qp[M]. qP  pair(M,q,p,qp)  qpl  is_forces_mem'(M,P,l,q,t1,t2))"

definition
  forces_eq_fm :: "[i,i,i,i,i]  i" where
  "forces_eq_fm(p,l,q,t1,t2) 
     Exists(Exists(Exists(And(number1_fm(2),And(empty_fm(1),
              And(is_tuple_fm(1,t1#+3,t2#+3,q#+3,0),frc_at_fm(p#+3,l#+3,0,2) ))))))"

definition
  forces_mem_fm :: "[i,i,i,i,i]  i" where
  "forces_mem_fm(p,l,q,t1,t2)  Exists(Exists(And(number1_fm(1),
                          And(is_tuple_fm(1,t1#+2,t2#+2,q#+2,0),frc_at_fm(p#+2,l#+2,0,1)))))"

definition
  forces_neq_fm :: "[i,i,i,i,i]  i" where
  "forces_neq_fm(p,l,q,t1,t2)  Neg(Exists(Exists(And(Member(1,p#+2),
     And(pair_fm(1,q#+2,0),And(Member(0,l#+2),forces_eq_fm(p#+2,l#+2,1,t1#+2,t2#+2)))))))"

definition
  forces_nmem_fm :: "[i,i,i,i,i]  i" where
  "forces_nmem_fm(p,l,q,t1,t2)  Neg(Exists(Exists(And(Member(1,p#+2),
     And(pair_fm(1,q#+2,0),And(Member(0,l#+2),forces_mem_fm(p#+2,l#+2,1,t1#+2,t2#+2)))))))"


lemma forces_eq_fm_type [TC]:
  " pnat;lnat;qnat;t1nat;t2nat  forces_eq_fm(p,l,q,t1,t2)  formula"
  unfolding forces_eq_fm_def
  by simp

lemma forces_mem_fm_type [TC]:
  " pnat;lnat;qnat;t1nat;t2nat  forces_mem_fm(p,l,q,t1,t2)  formula"
  unfolding forces_mem_fm_def
  by simp

lemma forces_neq_fm_type [TC]:
  " pnat;lnat;qnat;t1nat;t2nat  forces_neq_fm(p,l,q,t1,t2)  formula"
  unfolding forces_neq_fm_def
  by simp

lemma forces_nmem_fm_type [TC]:
  " pnat;lnat;qnat;t1nat;t2nat  forces_nmem_fm(p,l,q,t1,t2)  formula"
  unfolding forces_nmem_fm_def
  by simp

lemma arity_forces_eq_fm :
  "pnat  lnat  qnat  t1  nat  t2  nat 
   arity(forces_eq_fm(p,l,q,t1,t2)) = succ(t1)  succ(t2)  succ(q)  succ(p)  succ(l)"
  unfolding forces_eq_fm_def
  using number1arity__fm arity_empty_fm arity_is_tuple_fm arity_frc_at_fm
    pred_Un_distrib
  by auto

lemma arity_forces_mem_fm :
  "pnat  lnat  qnat  t1  nat  t2  nat 
   arity(forces_mem_fm(p,l,q,t1,t2)) = succ(t1)  succ(t2)  succ(q)  succ(p)  succ(l)"
  unfolding forces_mem_fm_def
  using number1arity__fm arity_empty_fm arity_is_tuple_fm arity_frc_at_fm
    pred_Un_distrib
  by auto

lemma sats_forces_eq'_fm:
  assumes  "pnat" "lnat" "qnat" "t1nat" "t2nat"  "envlist(M)"
  shows "sats(M,forces_eq_fm(p,l,q,t1,t2),env) 
         is_forces_eq'(##M,nth(p,env),nth(l,env),nth(q,env),nth(t1,env),nth(t2,env))"
  unfolding forces_eq_fm_def is_forces_eq'_def using assms sats_is_tuple_fm  sats_frc_at_fm
  by simp

lemma sats_forces_mem'_fm:
  assumes  "pnat" "lnat" "qnat" "t1nat" "t2nat"  "envlist(M)"
  shows "sats(M,forces_mem_fm(p,l,q,t1,t2),env) 
             is_forces_mem'(##M,nth(p,env),nth(l,env),nth(q,env),nth(t1,env),nth(t2,env))"
  unfolding forces_mem_fm_def is_forces_mem'_def using assms sats_is_tuple_fm sats_frc_at_fm
  by simp

lemma sats_forces_neq'_fm:
  assumes  "pnat" "lnat" "qnat" "t1nat" "t2nat"  "envlist(M)"
  shows "sats(M,forces_neq_fm(p,l,q,t1,t2),env) 
             is_forces_neq'(##M,nth(p,env),nth(l,env),nth(q,env),nth(t1,env),nth(t2,env))"
  unfolding forces_neq_fm_def is_forces_neq'_def
  using assms sats_forces_eq'_fm sats_is_tuple_fm sats_frc_at_fm
  by simp

lemma sats_forces_nmem'_fm:
  assumes  "pnat" "lnat" "qnat" "t1nat" "t2nat"  "envlist(M)"
  shows "sats(M,forces_nmem_fm(p,l,q,t1,t2),env) 
             is_forces_nmem'(##M,nth(p,env),nth(l,env),nth(q,env),nth(t1,env),nth(t2,env))"
  unfolding forces_nmem_fm_def is_forces_nmem'_def
  using assms sats_forces_mem'_fm sats_is_tuple_fm sats_frc_at_fm
  by simp

context forcing_data
begin

(* Absoluteness of components *)
lemma fst_abs [simp]:
  "xM; yM   is_fst(##M,x,y)  y = fst(x)"
  unfolding fst_def is_fst_def using pair_in_M_iff zero_in_M
  by (auto;rule_tac the_0 the_0[symmetric],auto)

lemma snd_abs [simp]:
  "xM; yM   is_snd(##M,x,y)  y = snd(x)"
  unfolding snd_def is_snd_def using pair_in_M_iff zero_in_M
  by (auto;rule_tac the_0 the_0[symmetric],auto)

lemma ftype_abs[simp] :
  "xM; yM   is_ftype(##M,x,y)  y = ftype(x)" unfolding ftype_def  is_ftype_def by simp

lemma name1_abs[simp] :
  "xM; yM   is_name1(##M,x,y)  y = name1(x)"
  unfolding name1_def is_name1_def
  by (rule hcomp_abs[OF fst_abs];simp_all add:fst_snd_closed)

lemma snd_snd_abs:
  "xM; yM   is_snd_snd(##M,x,y)  y = snd(snd(x))"
  unfolding is_snd_snd_def
  by (rule hcomp_abs[OF snd_abs];simp_all add:fst_snd_closed)

lemma name2_abs[simp]:
  "xM; yM   is_name2(##M,x,y)  y = name2(x)"
  unfolding name2_def is_name2_def
  by (rule hcomp_abs[OF fst_abs snd_snd_abs];simp_all add:fst_snd_closed)

lemma cond_of_abs[simp]:
  "xM; yM   is_cond_of(##M,x,y)  y = cond_of(x)"
  unfolding cond_of_def is_cond_of_def
  by (rule hcomp_abs[OF snd_abs snd_snd_abs];simp_all add:fst_snd_closed)

lemma tuple_abs[simp]:
  "zM;t1M;t2M;pM;tM 
   is_tuple(##M,z,t1,t2,p,t)  t = z,t1,t2,p"
  unfolding is_tuple_def using tuples_in_M by simp

lemma oneN_in_M[simp]: "1M"
  by (simp flip: setclass_iff)

lemma twoN_in_M : "2M"
  by (simp flip: setclass_iff)

lemma comp_in_M:
  "p  q  pM"
  "p  q  qM"
  using leq_in_M transitivity[of _ leq] pair_in_M_iff by auto

(* Absoluteness of Hfrc *)

lemma eq_case_abs [simp]:
  assumes
    "t1M" "t2M" "pM" "fM"
  shows
    "is_eq_case(##M,t1,t2,p,P,leq,f)  eq_case(t1,t2,p,P,leq,f)"
proof -
  have "q  p  qM" for q
    using comp_in_M by simp
  moreover
  have "s,yt  sdomain(t)" if "tM" for s y t
    using that unfolding domain_def by auto
  ultimately
  have
    "(sM. s  domain(t1)  s  domain(t2)  (qM. qP  q  p 
                              (f ` 1, s, t1, q =1  f ` 1, s, t2, q=1))) 
    (s. s  domain(t1)  s  domain(t2)  (q. qP  q  p 
                                  (f ` 1, s, t1, q =1  f ` 1, s, t2, q=1)))"
    using assms domain_trans[OF trans_M,of t1]
      domain_trans[OF trans_M,of t2] by auto
  then show ?thesis
    unfolding eq_case_def is_eq_case_def
    using assms pair_in_M_iff n_in_M[of 1] domain_closed tuples_in_M
      apply_closed leq_in_M
    by simp
qed

lemma mem_case_abs [simp]:
  assumes
    "t1M" "t2M" "pM" "fM"
  shows
    "is_mem_case(##M,t1,t2,p,P,leq,f)  mem_case(t1,t2,p,P,leq,f)"
proof
  {
    fix v
    assume "vP" "v  p" "is_mem_case(##M,t1,t2,p,P,leq,f)"
    moreover
    from this
    have "vM" "v,p  M" "(##M)(v)"
      using transitivity[OF _ P_in_M,of v] transitivity[OF _ leq_in_M]
      by simp_all
    moreover
    from calculation assms
    obtain q r s where
      "r  P  q  P  q, v  M  s, r  M  q, r  M  0  M 
       0, t1, s, q  M  q  v  s, r  t2  q  r  f ` 0, t1, s, q = 1"
      unfolding is_mem_case_def by auto
    then
    have "q s r. r  P  q  P  q  v  s, r  t2  q  r  f ` 0, t1, s, q = 1"
      by auto
  }
  then
  show "mem_case(t1, t2, p, P, leq, f)" if "is_mem_case(##M, t1, t2, p, P, leq, f)"
    unfolding mem_case_def using that assms by auto
next
  { fix v
    assume "v  M" "v  P" "v, p  M" "v  p" "mem_case(t1, t2, p, P, leq, f)"
    moreover
    from this
    obtain q s r where "r  P  q  P  q  v  s, r  t2  q  r  f ` 0, t1, s, q = 1"
      unfolding mem_case_def by auto
    moreover
    from this t2M
    have "rM" "qM" "sM" "r  P  q  P  q  v  s, r  t2  q  r  f ` 0, t1, s, q = 1"
      using transitivity P_in_M domain_closed[of t2] by auto
    moreover
    note t1M
    ultimately
    have "qM . sM. rM.
         r  P  q  P  q, v  M  s, r  M  q, r  M  0  M 
         0, t1, s, q  M  q  v  s, r  t2  q  r  f ` 0, t1, s, q = 1"
      using tuples_in_M zero_in_M by auto
  }
  then
  show "is_mem_case(##M, t1, t2, p, P, leq, f)" if "mem_case(t1, t2, p, P, leq, f)"
    unfolding is_mem_case_def using assms that by auto
qed


lemma Hfrc_abs:
  "fnncM; fM 
   is_Hfrc(##M,P,leq,fnnc,f)  Hfrc(P,leq,fnnc,f)"
  unfolding is_Hfrc_def Hfrc_def using pair_in_M_iff
  by auto

lemma Hfrc_at_abs:
  "fnncM; fM ; zM 
   is_Hfrc_at(##M,P,leq,fnnc,f,z)   z = bool_of_o(Hfrc(P,leq,fnnc,f)) "
  unfolding is_Hfrc_at_def using Hfrc_abs
  by auto

lemma components_closed :
  "xM  ftype(x)M"
  "xM  name1(x)M"
  "xM  name2(x)M"
  "xM  cond_of(x)M"
  unfolding ftype_def name1_def name2_def cond_of_def using fst_snd_closed by simp_all

lemma ecloseN_closed:
  "(##M)(A)  (##M)(ecloseN(A))"
  "(##M)(A)  (##M)(eclose_n(name1,A))"
  "(##M)(A)  (##M)(eclose_n(name2,A))"
  unfolding ecloseN_def eclose_n_def
  using components_closed eclose_closed singletonM Un_closed by auto

lemma is_eclose_n_abs :
  assumes "xM" "ecM"
  shows "is_eclose_n(##M,is_name1,ec,x)  ec = eclose_n(name1,x)"
    "is_eclose_n(##M,is_name2,ec,x)  ec = eclose_n(name2,x)"
  unfolding is_eclose_n_def eclose_n_def
  using assms name1_abs name2_abs eclose_abs singletonM components_closed
  by auto


lemma is_ecloseN_abs :
  "xM;ecM  is_ecloseN(##M,ec,x)  ec = ecloseN(x)"
  unfolding is_ecloseN_def ecloseN_def
  using is_eclose_n_abs Un_closed union_abs ecloseN_closed
  by auto

lemma frecR_abs :
  "xM  yM  frecR(x,y)  is_frecR(##M,x,y)"
  unfolding frecR_def is_frecR_def using components_closed domain_closed by simp

lemma frecrelP_abs :
  "zM  frecrelP(##M,z)  (x y. z = x,y  frecR(x,y))"
  using pair_in_M_iff frecR_abs unfolding frecrelP_def by auto

lemma frecrel_abs:
  assumes
    "AM" "rM"
  shows
    "is_frecrel(##M,A,r)   r = frecrel(A)"
proof -
  from AM
  have "zM" if "zA×A" for z
    using cartprod_closed transitivity that by simp
  then
  have "Collect(A×A,frecrelP(##M)) = Collect(A×A,λz. (x y. z = x,y  frecR(x,y)))"
    using Collect_cong[of "A×A" "A×A" "frecrelP(##M)"] assms frecrelP_abs by simp
  with assms
  show ?thesis unfolding is_frecrel_def def_frecrel using cartprod_closed
    by simp
qed

lemma frecrel_closed:
  assumes
    "xM"
  shows
    "frecrel(x)M"
proof -
  have "Collect(x×x,λz. (x y. z = x,y  frecR(x,y)))M"
    using Collect_in_M_0p[of "frecrelP_fm(0)"] arity_frecrelP_fm sats_frecrelP_fm
      frecrelP_abs xM cartprod_closed by simp
  then show ?thesis
    unfolding frecrel_def Rrel_def frecrelP_def by simp
qed

lemma field_frecrel : "field(frecrel(names_below(P,x)))  names_below(P,x)"
  unfolding frecrel_def
  using field_Rrel by simp

lemma forcerelD : "uv  forcerel(P,x)  uv names_below(P,x) × names_below(P,x)"
  unfolding forcerel_def
  using trancl_type field_frecrel by blast

lemma wf_forcerel :
  "wf(forcerel(P,x))"
  unfolding forcerel_def using wf_trancl wf_frecrel .

lemma restrict_trancl_forcerel:
  assumes "frecR(w,y)"
  shows "restrict(f,frecrel(names_below(P,x))-``{y})`w
       = restrict(f,forcerel(P,x)-``{y})`w"
  unfolding forcerel_def frecrel_def using assms restrict_trancl_Rrel[of frecR]
  by simp

lemma names_belowI :
  assumes "frecR(ft,n1,n2,p,a,b,c,d)" "pP"
  shows "ft,n1,n2,p  names_below(P,a,b,c,d)" (is "?x  names_below(_,?y)")
proof -
  from assms
  have "ft  2" "a  2"
    unfolding frecR_def by (auto simp add:components_simp)
  from assms
  consider (e) "n1  domain(b)  domain(c)  (n2 = b  n2 =c)"
    | (m) "n1 = b  n2  domain(c)"
    unfolding frecR_def by (auto simp add:components_simp)
  then show ?thesis
  proof cases
    case e
    then
    have "n1  eclose(b)  n1  eclose(c)"
      using Un_iff in_dom_in_eclose by auto
    with e
    have "n1  ecloseN(?y)" "n2  ecloseN(?y)"
      using ecloseNI components_in_eclose by auto
    with ft2 pP
    show ?thesis unfolding names_below_def by  auto
  next
    case m
    then
    have "n1  ecloseN(?y)" "n2  ecloseN(?y)"
      using mem_eclose_trans  ecloseNI
        in_dom_in_eclose components_in_eclose by auto
    with ft2 pP
    show ?thesis unfolding names_below_def
      by auto
  qed
qed

lemma names_below_tr :
  assumes "x names_below(P,y)"
    "y names_below(P,z)"
  shows "x names_below(P,z)"
proof -
  let ?A="λy . names_below(P,y)"
  from assms
  obtain fx x1 x2 px where
    "x = fx,x1,x2,px" "fx2" "x1ecloseN(y)" "x2ecloseN(y)" "pxP"
    unfolding names_below_def by auto
  from assms
  obtain fy y1 y2 py where
    "y = fy,y1,y2,py" "fy2" "y1ecloseN(z)" "y2ecloseN(z)" "pyP"
    unfolding names_below_def by auto
  from x1_ x2_ y1_ y2_ x=_ y=_
  have "x1ecloseN(z)" "x2ecloseN(z)"
    using ecloseN_mono names_simp by auto
  with fx2 pxP x=_
  have "x?A(z)"
    unfolding names_below_def by simp
  then show ?thesis using subsetI by simp
qed

lemma arg_into_names_below2 :
  assumes "x,y  frecrel(names_below(P,z))"
  shows  "x  names_below(P,y)"
proof -
  {
    from assms
    have "xnames_below(P,z)" "ynames_below(P,z)" "frecR(x,y)"
      unfolding frecrel_def Rrel_def
      by auto
    obtain f n1 n2 p where
      "x = f,n1,n2,p" "f2" "n1ecloseN(z)" "n2ecloseN(z)" "pP"
      using xnames_below(P,z)
      unfolding names_below_def by auto
    moreover
    obtain fy m1 m2 q where
      "qP" "y = fy,m1,m2,q"
      using ynames_below(P,z)
      unfolding names_below_def by auto
    moreover
    note ‹frecR(x,y)
    ultimately
    have "xnames_below(P,y)" using names_belowI by simp
  }
  then show ?thesis .
qed

lemma arg_into_names_below :
  assumes "x,y  frecrel(names_below(P,z))"
  shows  "x  names_below(P,x)"
proof -
  {
    from assms
    have "xnames_below(P,z)"
      unfolding frecrel_def Rrel_def
      by auto
    from xnames_below(P,z)
    obtain f n1 n2 p where
      "x = f,n1,n2,p" "f2" "n1ecloseN(z)" "n2ecloseN(z)" "pP"
      unfolding names_below_def by auto
    then
    have "n1ecloseN(x)" "n2ecloseN(x)"
      using components_in_eclose by simp_all
    with f2 pP x = f,n1,n2,p
    have "xnames_below(P,x)"
      unfolding names_below_def by simp
  }
  then show ?thesis .
qed

lemma forcerel_arg_into_names_below :
  assumes "x,y  forcerel(P,z)"
  shows  "x  names_below(P,x)"
  using assms
  unfolding forcerel_def
  by(rule trancl_induct;auto simp add: arg_into_names_below)

lemma names_below_mono :
  assumes "x,y  frecrel(names_below(P,z))"
  shows "names_below(P,x)  names_below(P,y)"
proof -
  from assms
  have "xnames_below(P,y)"
    using arg_into_names_below2 by simp
  then
  show ?thesis
    using names_below_tr subsetI by simp
qed

lemma frecrel_mono :
  assumes "x,y  frecrel(names_below(P,z))"
  shows "frecrel(names_below(P,x))  frecrel(names_below(P,y))"
  unfolding frecrel_def
  using Rrel_mono names_below_mono assms by simp

lemma forcerel_mono2 :
  assumes "x,y  frecrel(names_below(P,z))"
  shows "forcerel(P,x)  forcerel(P,y)"
  unfolding forcerel_def
  using trancl_mono frecrel_mono assms by simp

lemma forcerel_mono_aux :
  assumes "x,y  frecrel(names_below(P, w))^+"
  shows "forcerel(P,x)  forcerel(P,y)"
  using assms
  by (rule trancl_induct,simp_all add: subset_trans forcerel_mono2)

lemma forcerel_mono :
  assumes "x,y  forcerel(P,z)"
  shows "forcerel(P,x)  forcerel(P,y)"
  using forcerel_mono_aux assms unfolding forcerel_def by simp

lemma aux: "x  names_below(P, w)  x,y  forcerel(P,z) 
  (y  names_below(P, w)  x,y  forcerel(P,w))"
  unfolding forcerel_def
proof(rule_tac a=x and b=y and P="λ y . y  names_below(P, w)  x,y  frecrel(names_below(P,w))^+" in trancl_induct,simp)
  let ?A="λ a . names_below(P, a)"
  let ?R="λ a . frecrel(?A(a))"
  let ?fR="λ a .forcerel(a)"
  show "u?A(w)  x,u?R(w)^+" if "x?A(w)" "x,y?R(z)^+" "x,u?R(z)"  for  u
    using that frecrelD frecrelI r_into_trancl unfolding names_below_def by simp
  {
    fix u v
    assume "x  ?A(w)"
      "x, y  ?R(z)^+"
      "x, u  ?R(z)^+"
      "u, v  ?R(z)"
      "u  ?A(w)  x, u  ?R(w)^+"
    then
    have "v  ?A(w)  x, v  ?R(w)^+"
    proof -
      assume "v ?A(w)"
      from u,v_
      have "u?A(v)"
        using arg_into_names_below2 by simp
      with v ?A(w)
      have "u?A(w)"
        using names_below_tr by simp
      with v_ u,v_
      have "u,v ?R(w)"
        using frecrelD frecrelI r_into_trancl unfolding names_below_def by simp
      with u  ?A(w)  x, u  ?R(w)^+ u?A(w)
      have "x, u  ?R(w)^+" by simp
      with u,v ?R(w)
      show "x,v ?R(w)^+" using trancl_trans r_into_trancl
        by simp
    qed
  }
  then show "v  ?A(w)  x, v  ?R(w)^+"
    if "x  ?A(w)"
      "x, y  ?R(z)^+"
      "x, u  ?R(z)^+"
      "u, v  ?R(z)"
      "u  ?A(w)  x, u  ?R(w)^+" for u v
    using that by simp
qed

lemma forcerel_eq :
  assumes "z,x  forcerel(P,x)"
  shows "forcerel(P,z) = forcerel(P,x)  names_below(P,z)×names_below(P,z)"
  using assms aux forcerelD forcerel_mono[of z x x] subsetI
  by auto

lemma forcerel_below_aux :
  assumes "z,x  forcerel(P,x)" "u,z  forcerel(P,x)"
  shows "u  names_below(P,z)"
  using assms(2)
  unfolding forcerel_def
proof(rule trancl_induct)
  show  "u  names_below(P,y)" if " u, y  frecrel(names_below(P, x))" for y
    using that vimage_singleton_iff arg_into_names_below2 by simp
next
  show "u  names_below(P,z)"
    if "u, y  frecrel(names_below(P, x))^+"
      "y, z  frecrel(names_below(P, x))"
      "u  names_below(P, y)"
    for y z
    using that arg_into_names_below2[of y z x] names_below_tr by simp
qed

lemma forcerel_below :
  assumes "z,x  forcerel(P,x)"
  shows "forcerel(P,x) -`` {z}  names_below(P,z)"
  using vimage_singleton_iff assms forcerel_below_aux by auto

lemma relation_forcerel :
  shows "relation(forcerel(P,z))" "trans(forcerel(P,z))"
  unfolding forcerel_def using relation_trancl trans_trancl by simp_all

lemma Hfrc_restrict_trancl: "bool_of_o(Hfrc(P, leq, y, restrict(f,frecrel(names_below(P,x))-``{y})))
         = bool_of_o(Hfrc(P, leq, y, restrict(f,(frecrel(names_below(P,x))^+)-``{y})))"
  unfolding Hfrc_def bool_of_o_def eq_case_def mem_case_def
  using restrict_trancl_forcerel frecRI1 frecRI2 frecRI3
  unfolding forcerel_def
  by simp

(* Recursive definition of forces for atomic formulas using a transitive relation *)
lemma frc_at_trancl: "frc_at(P,leq,z) = wfrec(forcerel(P,z),z,λx f. bool_of_o(Hfrc(P,leq,x,f)))"
  unfolding frc_at_def forcerel_def using wf_eq_trancl Hfrc_restrict_trancl by simp


lemma forcerelI1 :
  assumes "n1  domain(b)  n1  domain(c)" "pP" "dP"
  shows "1, n1, b, p, 0,b,c,d forcerel(P,0,b,c,d)"
proof -
  let ?x="1, n1, b, p"
  let ?y="0,b,c,d"
  from assms
  have "frecR(?x,?y)"
    using frecRI1 by simp
  then
  have "?xnames_below(P,?y)"  "?y  names_below(P,?y)"
    using names_belowI  assms components_in_eclose
    unfolding names_below_def by auto
  with ‹frecR(?x,?y)
  show ?thesis
    unfolding forcerel_def frecrel_def
    using subsetD[OF r_subset_trancl[OF relation_Rrel]] RrelI
    by auto
qed

lemma forcerelI2 :
  assumes "n1  domain(b)  n1  domain(c)" "pP" "dP"
  shows "1, n1, c, p, 0,b,c,d forcerel(P,0,b,c,d)"
proof -
  let ?x="1, n1, c, p"
  let ?y="0,b,c,d"
  from assms
  have "frecR(?x,?y)"
    using frecRI2 by simp
  then
  have "?xnames_below(P,?y)"  "?y  names_below(P,?y)"
    using names_belowI  assms components_in_eclose
    unfolding names_below_def by auto
  with ‹frecR(?x,?y)
  show ?thesis
    unfolding forcerel_def frecrel_def
    using subsetD[OF r_subset_trancl[OF relation_Rrel]] RrelI
    by auto
qed

lemma forcerelI3 :
  assumes "n2, r  c" "pP" "dP" "r  P"
  shows "0, b, n2, p,1, b, c, d  forcerel(P,1,b,c,d)"
proof -
  let ?x="0, b, n2, p"
  let ?y="1, b, c, d"
  from assms
  have "frecR(?x,?y)"
    using assms frecRI3 by simp
  then
  have "?xnames_below(P,?y)"  "?y  names_below(P,?y)"
    using names_belowI  assms components_in_eclose
    unfolding names_below_def by auto
  with ‹frecR(?x,?y)
  show ?thesis
    unfolding forcerel_def frecrel_def
    using subsetD[OF r_subset_trancl[OF relation_Rrel]] RrelI
    by auto
qed

lemmas forcerelI = forcerelI1[THEN vimage_singleton_iff[THEN iffD2]]
  forcerelI2[THEN vimage_singleton_iff[THEN iffD2]]
  forcerelI3[THEN vimage_singleton_iff[THEN iffD2]]

lemma  aux_def_frc_at:
  assumes "z  forcerel(P,x) -`` {x}"
  shows "wfrec(forcerel(P,x), z, H) =  wfrec(forcerel(P,z), z, H)"
proof -
  let ?A="names_below(P,z)"
  from assms
  have "z,x  forcerel(P,x)"
    using vimage_singleton_iff by simp
  then
  have "z  ?A"
    using forcerel_arg_into_names_below by simp
  from z,x  forcerel(P,x)
  have E:"forcerel(P,z) = forcerel(P,x)  (?A×?A)"
    "forcerel(P,x) -`` {z}  ?A"
    using forcerel_eq forcerel_below
    by auto
  with z?A
  have "wfrec(forcerel(P,x), z, H) = wfrec[?A](forcerel(P,x), z, H)"
    using wfrec_trans_restr[OF relation_forcerel(1) wf_forcerel relation_forcerel(2), of x z ?A]
    by simp
  then show ?thesis
    using E wfrec_restr_eq by simp
qed

subsection‹Recursive expression of term‹frc_at›

lemma def_frc_at :
  assumes "pP"
  shows
    "frc_at(P,leq,ft,n1,n2,p) =
   bool_of_o( p P 
  (  ft = 0   (s. sdomain(n1)  domain(n2) 
        (q. qP  q  p  (frc_at(P,leq,1,s,n1,q) =1  frc_at(P,leq,1,s,n2,q) =1)))
    ft = 1  ( vP. v  p 
    (q. s. r. rP  qP  q  v  s,r  n2  q  r   frc_at(P,leq,0,n1,s,q) = 1))))"
proof -
  let ?r="λy. forcerel(P,y)" and ?Hf="λx f. bool_of_o(Hfrc(P,leq,x,f))"
  let ?t="λy. ?r(y) -`` {y}"
  let ?arg="ft,n1,n2,p"
  from wf_forcerel
  have wfr: "w . wf(?r(w))" ..
  with wfrec [of "?r(?arg)" ?arg ?Hf]
  have "frc_at(P,leq,?arg) = ?Hf( ?arg, λx?r(?arg) -`` {?arg}. wfrec(?r(?arg), x, ?Hf))"
    using frc_at_trancl by simp
  also
  have " ... = ?Hf( ?arg, λx?r(?arg) -`` {?arg}. frc_at(P,leq,x))"
    using aux_def_frc_at frc_at_trancl by simp
  finally
  show ?thesis
    unfolding Hfrc_def mem_case_def eq_case_def
    using forcerelI  assms
    by auto
qed


subsection‹Absoluteness of term‹frc_at›

lemma trans_forcerel_t : "trans(forcerel(P,x))"
  unfolding forcerel_def using trans_trancl .

lemma relation_forcerel_t : "relation(forcerel(P,x))"
  unfolding forcerel_def using relation_trancl .


lemma forcerel_in_M :
  assumes
    "xM"
  shows
    "forcerel(P,x)M"
  unfolding forcerel_def def_frecrel names_below_def
proof -
  let ?Q = "2 × ecloseN(x) × ecloseN(x) × P"
  have "?Q × ?Q  M"
    using xM P_in_M twoN_in_M ecloseN_closed cartprod_closed by simp
  moreover
  have "separation(##M,λz. x y. z = x, y  frecR(x, y))"
  proof -
    have "arity(frecrelP_fm(0)) = 1"
      unfolding number1_fm_def frecrelP_fm_def
      by (simp del:FOL_sats_iff pair_abs empty_abs
          add: fm_defs frecR_fm_def number1_fm_def components_defs nat_simp_union)
    then
    have "separation(##M, λz. sats(M,frecrelP_fm(0) , [z]))"
      using separation_ax by simp
    moreover
    have "frecrelP(##M,z)  sats(M,frecrelP_fm(0),[z])"
      if "zM" for z
      using that sats_frecrelP_fm[of 0 "[z]"] by simp
    ultimately
    have "separation(##M,frecrelP(##M))"
      unfolding separation_def by simp
    then
    show ?thesis using frecrelP_abs
        separation_cong[of "##M" "frecrelP(##M)" "λz. x y. z = x, y  frecR(x, y)"]
      by simp
  qed
  ultimately
  show "{z  ?Q × ?Q . x y. z = x, y  frecR(x, y)}^+  M"
    using separation_closed frecrelP_abs trancl_closed by simp
qed

lemma relation2_Hfrc_at_abs:
  "relation2(##M,is_Hfrc_at(##M,P,leq),λx f. bool_of_o(Hfrc(P,leq,x,f)))"
  unfolding relation2_def using Hfrc_at_abs
  by simp

lemma Hfrc_at_closed :
  "xM. gM. function(g)  bool_of_o(Hfrc(P,leq,x,g))M"
  unfolding bool_of_o_def using zero_in_M n_in_M[of 1] by simp

lemma wfrec_Hfrc_at :
  assumes
    "XM"
  shows
    "wfrec_replacement(##M,is_Hfrc_at(##M,P,leq),forcerel(P,X))"
proof -
  have 0:"is_Hfrc_at(##M,P,leq,a,b,c) 
        sats(M,Hfrc_at_fm(8,9,2,1,0),[c,b,a,d,e,y,x,z,P,leq,forcerel(P,X)])"
    if "aM" "bM" "cM" "dM" "eM" "yM" "xM" "zM"
    for a b c d e y x z
    using that P_in_M leq_in_M XM forcerel_in_M
      is_Hfrc_at_iff_sats[of concl:M P leq a b c 8 9 2 1 0
        "[c,b,a,d,e,y,x,z,P,leq,forcerel(P,X)]"] by simp
  have 1:"sats(M,is_wfrec_fm(Hfrc_at_fm(8,9,2,1,0),5,1,0),[y,x,z,P,leq,forcerel(P,X)]) 
                   is_wfrec(##M, is_Hfrc_at(##M,P,leq),forcerel(P,X), x, y)"
    if "xM" "yM" "zM" for x y z
    using  that XM forcerel_in_M P_in_M leq_in_M
      sats_is_wfrec_fm[OF 0]
    by simp
  let
    ?f="Exists(And(pair_fm(1,0,2),is_wfrec_fm(Hfrc_at_fm(8,9,2,1,0),5,1,0)))"
  have satsf:"sats(M, ?f, [x,z,P,leq,forcerel(P,X)]) 
              (yM. pair(##M,x,y,z) & is_wfrec(##M, is_Hfrc_at(##M,P,leq),forcerel(P,X), x, y))"
    if "xM" "zM" for x z
    using that 1 XM forcerel_in_M P_in_M leq_in_M by (simp del:pair_abs)
  have artyf:"arity(?f) = 5"
    unfolding is_wfrec_fm_def Hfrc_at_fm_def Hfrc_fm_def Replace_fm_def PHcheck_fm_def
      pair_fm_def upair_fm_def is_recfun_fm_def fun_apply_fm_def big_union_fm_def
      pre_image_fm_def restriction_fm_def image_fm_def fm_defs number1_fm_def
      eq_case_fm_def mem_case_fm_def is_tuple_fm_def
    by (simp add:nat_simp_union)
  moreover
  have "?fformula"
    unfolding fm_defs Hfrc_at_fm_def by simp
  ultimately
  have "strong_replacement(##M,λx z. sats(M,?f,[x,z,P,leq,forcerel(P,X)]))"
    using replacement_ax 1 artyf XM forcerel_in_M P_in_M leq_in_M by simp
  then
  have "strong_replacement(##M,λx z.
          yM. pair(##M,x,y,z) & is_wfrec(##M, is_Hfrc_at(##M,P,leq),forcerel(P,X), x, y))"
    using repl_sats[of M ?f "[P,leq,forcerel(P,X)]"] satsf by (simp del:pair_abs)
  then
  show ?thesis unfolding wfrec_replacement_def by simp
qed

lemma names_below_abs :
  "QM;xM;nbM  is_names_below(##M,Q,x,nb)  nb = names_below(Q,x)"
  unfolding is_names_below_def names_below_def
  using succ_in_M_iff zero_in_M cartprod_closed is_ecloseN_abs ecloseN_closed
  by auto

lemma names_below_closed:
  "QM;xM  names_below(Q,x)  M"
  unfolding names_below_def
  using zero_in_M cartprod_closed ecloseN_closed succ_in_M_iff
  by simp

lemma "names_below_productE" :
  assumes "Q  M" "x  M"
    "A1 A2 A3 A4. A1  M  A2  M  A3  M  A4  M  R(A1 × A2 × A3 × A4)"
  shows "R(names_below(Q,x))"
  unfolding names_below_def using assms zero_in_M ecloseN_closed[of x] twoN_in_M by auto

lemma forcerel_abs :
  "xM;zM  is_forcerel(##M,P,x,z)  z = forcerel(P,x)"
  unfolding is_forcerel_def forcerel_def
  using frecrel_abs names_below_abs trancl_abs P_in_M twoN_in_M ecloseN_closed names_below_closed
    names_below_productE[of concl:"λp. is_frecrel(##M,p,_)   _ = frecrel(p)"] frecrel_closed
  by simp

lemma frc_at_abs:
  assumes "fnncM" "zM"
  shows "is_frc_at(##M,P,leq,fnnc,z)  z = frc_at(P,leq,fnnc)"
proof -
  from assms
  have "(rM. is_forcerel(##M,P,fnnc, r)  is_wfrec(##M, is_Hfrc_at(##M, P, leq), r, fnnc, z))
         is_wfrec(##M, is_Hfrc_at(##M, P, leq), forcerel(P,fnnc), fnnc, z)"
    using forcerel_abs forcerel_in_M by simp
  then
  show ?thesis
    unfolding frc_at_trancl is_frc_at_def
    using assms wfrec_Hfrc_at[of fnnc] wf_forcerel trans_forcerel_t relation_forcerel_t forcerel_in_M
      Hfrc_at_closed relation2_Hfrc_at_abs
      trans_wfrec_abs[of "forcerel(P,fnnc)" fnnc z "is_Hfrc_at(##M,P,leq)" "λx f. bool_of_o(Hfrc(P,leq,x,f))"]
    by (simp flip:setclass_iff)
qed

lemma forces_eq'_abs :
  "pM ; t1M ; t2M  is_forces_eq'(##M,P,leq,p,t1,t2)  forces_eq'(P,leq,p,t1,t2)"
  unfolding is_forces_eq'_def forces_eq'_def
  using frc_at_abs zero_in_M tuples_in_M by auto

lemma forces_mem'_abs :
  "pM ; t1M ; t2M  is_forces_mem'(##M,P,leq,p,t1,t2)  forces_mem'(P,leq,p,t1,t2)"
  unfolding is_forces_mem'_def forces_mem'_def
  using frc_at_abs zero_in_M tuples_in_M by auto

lemma forces_neq'_abs :
  assumes
    "pM" "t1M" "t2M"
  shows
    "is_forces_neq'(##M,P,leq,p,t1,t2)  forces_neq'(P,leq,p,t1,t2)"
proof -
  have "qM" if "qP" for q
    using that transitivity P_in_M by simp
  then show ?thesis
    unfolding is_forces_neq'_def forces_neq'_def
    using assms forces_eq'_abs pair_in_M_iff
    by (auto,blast)
qed


lemma forces_nmem'_abs :
  assumes
    "pM" "t1M" "t2M"
  shows
    "is_forces_nmem'(##M,P,leq,p,t1,t2)  forces_nmem'(P,leq,p,t1,t2)"
proof -
  have "qM" if "qP" for q
    using that transitivity P_in_M by simp
  then show ?thesis
    unfolding is_forces_nmem'_def forces_nmem'_def
    using assms forces_mem'_abs pair_in_M_iff
    by (auto,blast)
qed

end (* forcing_data *)

subsection‹Forcing for general formulas›

definition
  ren_forces_nand :: "ii" where
  "ren_forces_nand(φ)  Exists(And(Equal(0,1),iterates(λp. incr_bv(p)`1 , 2, φ)))"

lemma ren_forces_nand_type[TC] :
  "φformula  ren_forces_nand(φ) formula"
  unfolding ren_forces_nand_def
  by simp

lemma arity_ren_forces_nand :
  assumes "φformula"
  shows "arity(ren_forces_nand(φ))  succ(arity(φ))"
proof -
  consider (lt) "1<arity(φ)" | (ge) "¬ 1 < arity(φ)"
    by auto
  then
  show ?thesis
  proof cases
    case lt
    with φ_
    have "2 < succ(arity(φ))" "2<arity(φ)#+2"
      using succ_ltI by auto
    with φ_
    have "arity(iterates(λp. incr_bv(p)`1,2,φ)) = 2#+arity(φ)"
      using arity_incr_bv_lemma lt
      by auto
    with φ_
    show ?thesis
      unfolding ren_forces_nand_def
      using lt pred_Un_distrib nat_union_abs1 Un_assoc[symmetric] Un_le_compat
      by simp
  next
    case ge
    with φ_
    have "arity(φ)  1" "pred(arity(φ))  1"
      using not_lt_iff_le le_trans[OF le_pred]
      by simp_all
    with φ_
    have "arity(iterates(λp. incr_bv(p)`1,2,φ)) = (arity(φ))"
      using arity_incr_bv_lemma ge
      by simp
    with ‹arity(φ)  1 φ_ ‹pred(_)  1
    show ?thesis
      unfolding ren_forces_nand_def
      using  pred_Un_distrib nat_union_abs1 Un_assoc[symmetric] nat_union_abs2
      by simp
  qed
qed

lemma sats_ren_forces_nand:
  "[q,P,leq,o,p] @ env  list(M)  φformula 
   sats(M, ren_forces_nand(φ),[q,p,P,leq,o] @ env)  sats(M, φ,[q,P,leq,o] @ env)"
  unfolding ren_forces_nand_def
  using sats_incr_bv_iff [of _ _ M _ "[q]"]
  by simp


definition
  ren_forces_forall :: "ii" where
  "ren_forces_forall(φ) 
      Exists(Exists(Exists(Exists(Exists(
        And(Equal(0,6),And(Equal(1,7),And(Equal(2,8),And(Equal(3,9),
        And(Equal(4,5),iterates(λp. incr_bv(p)`5 , 5, φ)))))))))))"

lemma arity_ren_forces_all :
  assumes "φformula"
  shows "arity(ren_forces_forall(φ)) = 5  arity(φ)"
proof -
  consider (lt) "5<arity(φ)" | (ge) "¬ 5 < arity(φ)"
    by auto
  then
  show ?thesis
  proof cases
    case lt
    with φ_
    have "5 < succ(arity(φ))" "5<arity(φ)#+2"  "5<arity(φ)#+3"  "5<arity(φ)#+4"
      using succ_ltI by auto
    with φ_
    have "arity(iterates(λp. incr_bv(p)`5,5,φ)) = 5#+arity(φ)"
      using arity_incr_bv_lemma lt
      by simp
    with φ_
    show ?thesis
      unfolding ren_forces_forall_def
      using pred_Un_distrib nat_union_abs1 Un_assoc[symmetric] nat_union_abs2
      by simp
  next
    case ge
    with φ_
    have "arity(φ)  5" "pred^5(arity(φ))  5"
      using not_lt_iff_le le_trans[OF le_pred]
      by simp_all
    with φ_
    have "arity(iterates(λp. incr_bv(p)`5,5,φ)) = arity(φ)"
      using arity_incr_bv_lemma ge
      by simp
    with ‹arity(φ)  5 φ_ ‹pred^5(_)  5
    show ?thesis
      unfolding ren_forces_forall_def
      using  pred_Un_distrib nat_union_abs1 Un_assoc[symmetric] nat_union_abs2
      by simp
  qed
qed

lemma ren_forces_forall_type[TC] :
  "φformula  ren_forces_forall(φ) formula"
  unfolding ren_forces_forall_def by simp

lemma sats_ren_forces_forall :
  "[x,P,leq,o,p] @ env  list(M)  φformula 
    sats(M, ren_forces_forall(φ),[x,p,P,leq,o] @ env)  sats(M, φ,[p,P,leq,o,x] @ env)"
  unfolding ren_forces_forall_def
  using sats_incr_bv_iff [of _ _ M _ "[p,P,leq,o,x]"]
  by simp


definition
  is_leq :: "[io,i,i,i]  o" where
  "is_leq(A,l,q,p)  qp[A]. (pair(A,q,p,qp)  qpl)"

lemma (in forcing_data) leq_abs[simp]:
  " lM ; qM ; pM   is_leq(##M,l,q,p)  q,pl"
  unfolding is_leq_def using pair_in_M_iff by simp


definition
  leq_fm :: "[i,i,i]  i" where
  "leq_fm(leq,q,p)  Exists(And(pair_fm(q#+1,p#+1,0),Member(0,leq#+1)))"

lemma arity_leq_fm :
  "leqnat;qnat;pnat  arity(leq_fm(leq,q,p)) = succ(q)  succ(p)  succ(leq)"
  unfolding leq_fm_def
  using arity_pair_fm pred_Un_distrib nat_simp_union
  by auto

lemma leq_fm_type[TC] :
  "leqnat;qnat;pnat  leq_fm(leq,q,p)formula"
  unfolding leq_fm_def by simp

lemma sats_leq_fm :
  " leqnat;qnat;pnat;envlist(A)  
     sats(A,leq_fm(leq,q,p),env)  is_leq(##A,nth(leq,env),nth(q,env),nth(p,env))"
  unfolding leq_fm_def is_leq_def by simp

subsubsection‹The primitive recursion›

consts forces' :: "ii"
primrec
  "forces'(Member(x,y)) = forces_mem_fm(1,2,0,x#+4,y#+4)"
  "forces'(Equal(x,y))  = forces_eq_fm(1,2,0,x#+4,y#+4)"
  "forces'(Nand(p,q))   =
        Neg(Exists(And(Member(0,2),And(leq_fm(3,0,1),And(ren_forces_nand(forces'(p)),
                                         ren_forces_nand(forces'(q)))))))"
  "forces'(Forall(p))   = Forall(ren_forces_forall(forces'(p)))"


definition
  forces :: "ii" where
  "forces(φ)  And(Member(0,1),forces'(φ))"

lemma forces'_type [TC]:  "φformula  forces'(φ)  formula"
  by (induct φ set:formula; simp)

lemma forces_type[TC] : "φformula  forces(φ)  formula"
  unfolding forces_def by simp

context forcing_data
begin

subsection‹Forcing for atomic formulas in context›

definition
  forces_eq :: "[i,i,i]  o" where
  "forces_eq  forces_eq'(P,leq)"

definition
  forces_mem :: "[i,i,i]  o" where
  "forces_mem  forces_mem'(P,leq)"

(* frc_at(P,leq,⟨0,t1,t2,p⟩) = 1*)
definition
  is_forces_eq :: "[i,i,i]  o" where
  "is_forces_eq  is_forces_eq'(##M,P,leq)"

(* frc_at(P,leq,⟨1,t1,t2,p⟩) = 1*)
definition
  is_forces_mem :: "[i,i,i]  o" where
  "is_forces_mem  is_forces_mem'(##M,P,leq)"


lemma def_forces_eq: "pP  forces_eq(p,t1,t2) 
      (sdomain(t1)  domain(t2). q. qP  q  p 
      (forces_mem(q,s,t1)  forces_mem(q,s,t2)))"
  unfolding forces_eq_def forces_mem_def forces_eq'_def forces_mem'_def
  using def_frc_at[of p 0 t1 t2 ]  unfolding bool_of_o_def
  by auto

lemma def_forces_mem: "pP  forces_mem(p,t1,t2) 
     (vP. v  p 
      (q. s. r. rP  qP  q  v  s,r  t2  q  r  forces_eq(q,t1,s)))"
  unfolding forces_eq'_def forces_mem'_def forces_eq_def forces_mem_def
  using def_frc_at[of p 1 t1 t2]  unfolding bool_of_o_def
  by auto

lemma forces_eq_abs :
  "pM ; t1M ; t2M  is_forces_eq(p,t1,t2)  forces_eq(p,t1,t2)"
  unfolding is_forces_eq_def forces_eq_def
  using forces_eq'_abs by simp

lemma forces_mem_abs :
  "pM ; t1M ; t2M  is_forces_mem(p,t1,t2)  forces_mem(p,t1,t2)"
  unfolding is_forces_mem_def forces_mem_def
  using forces_mem'_abs by simp

lemma sats_forces_eq_fm:
  assumes  "pnat" "lnat" "qnat" "t1nat" "t2nat"  "envlist(M)"
    "nth(p,env)=P" "nth(l,env)=leq"
  shows "sats(M,forces_eq_fm(p,l,q,t1,t2),env) 
         is_forces_eq(nth(q,env),nth(t1,env),nth(t2,env))"
  unfolding forces_eq_fm_def is_forces_eq_def is_forces_eq'_def
  using assms sats_is_tuple_fm  sats_frc_at_fm
  by simp

lemma sats_forces_mem_fm:
  assumes  "pnat" "lnat" "qnat" "t1nat" "t2nat"  "envlist(M)"
    "nth(p,env)=P" "nth(l,env)=leq"
  shows "sats(M,forces_mem_fm(p,l,q,t1,t2),env) 
             is_forces_mem(nth(q,env),nth(t1,env),nth(t2,env))"
  unfolding forces_mem_fm_def is_forces_mem_def is_forces_mem'_def
  using assms sats_is_tuple_fm sats_frc_at_fm
  by simp


definition
  forces_neq :: "[i,i,i]  o" where
  "forces_neq(p,t1,t2)  ¬ (qP. qp  forces_eq(q,t1,t2))"

definition
  forces_nmem :: "[i,i,i]  o" where
  "forces_nmem(p,t1,t2)  ¬ (qP. qp  forces_mem(q,t1,t2))"


lemma forces_neq :
  "forces_neq(p,t1,t2)  forces_neq'(P,leq,p,t1,t2)"
  unfolding forces_neq_def forces_neq'_def forces_eq_def by simp

lemma forces_nmem :
  "forces_nmem(p,t1,t2)  forces_nmem'(P,leq,p,t1,t2)"
  unfolding forces_nmem_def forces_nmem'_def forces_mem_def by simp


lemma sats_forces_Member :
  assumes  "xnat" "ynat" "envlist(M)"
    "nth(x,env)=xx" "nth(y,env)=yy" "qM"
  shows "sats(M,forces(Member(x,y)),[q,P,leq,one]@env) 
                (qP  is_forces_mem(q,xx,yy))"
  unfolding forces_def
  using assms sats_forces_mem_fm P_in_M leq_in_M one_in_M
  by simp

lemma sats_forces_Equal :
  assumes  "xnat" "ynat" "envlist(M)"
    "nth(x,env)=xx" "nth(y,env)=yy" "qM"
  shows "sats(M,forces(Equal(x,y)),[q,P,leq,one]@env) 
                (qP  is_forces_eq(q,xx,yy))"
  unfolding forces_def
  using assms sats_forces_eq_fm P_in_M leq_in_M one_in_M
  by simp

lemma sats_forces_Nand :
  assumes  "φformula" "ψformula" "envlist(M)" "pM"
  shows "sats(M,forces(Nand(φ,ψ)),[p,P,leq,one]@env) 
         (pP  ¬(qM. qP  is_leq(##M,leq,q,p) 
               (sats(M,forces'(φ),[q,P,leq,one]@env)  sats(M,forces'(ψ),[q,P,leq,one]@env))))"
  unfolding forces_def using sats_leq_fm assms sats_ren_forces_nand P_in_M leq_in_M one_in_M
  by simp

lemma sats_forces_Neg :
  assumes  "φformula" "envlist(M)" "pM"
  shows "sats(M,forces(Neg(φ)),[p,P,leq,one]@env) 
         (pP  ¬(qM. qP  is_leq(##M,leq,q,p) 
               (sats(M,forces'(φ),[q,P,leq,one]@env))))"
  unfolding Neg_def using assms sats_forces_Nand
  by simp

lemma sats_forces_Forall :
  assumes  "φformula" "envlist(M)" "pM"
  shows "sats(M,forces(Forall(φ)),[p,P,leq,one]@env) 
         pP  (xM. sats(M,forces'(φ),[p,P,leq,one,x]@env))"
  unfolding forces_def using assms sats_ren_forces_forall P_in_M leq_in_M one_in_M
  by simp

end (* forcing_data *)

subsection‹The arity of term‹forces›

lemma arity_forces_at:
  assumes  "x  nat" "y  nat"
  shows "arity(forces(Member(x, y))) = (succ(x)  succ(y)) #+ 4"
    "arity(forces(Equal(x, y))) = (succ(x)  succ(y)) #+ 4"
  unfolding forces_def
  using assms arity_forces_mem_fm arity_forces_eq_fm succ_Un_distrib nat_simp_union
  by auto

lemma arity_forces':
  assumes "φformula"
  shows "arity(forces'(φ))  arity(φ) #+ 4"
  using assms
proof (induct set:formula)
  case (Member x y)
  then
  show ?case
    using arity_forces_mem_fm succ_Un_distrib nat_simp_union
    by simp
next
  case (Equal x y)
  then
  show ?case
    using arity_forces_eq_fm succ_Un_distrib nat_simp_union
    by simp
next
  case (Nand φ ψ)
  let ?φ' = "ren_forces_nand(forces'(φ))"
  let ?ψ' = "ren_forces_nand(forces'(ψ))"
  have "arity(leq_fm(3, 0, 1)) = 4"
    using arity_leq_fm succ_Un_distrib nat_simp_union
    by simp
  have "3  (4#+arity(φ))  (4#+arity(ψ))" (is "_  ?rhs")
    using nat_simp_union by simp
  from φ_ Nand
  have "pred(arity(?φ'))  ?rhs"  "pred(arity(?ψ'))  ?rhs"
  proof -
    from φ_ ψ_
    have A:"pred(arity(?φ'))  arity(forces'(φ))"
      "pred(arity(?ψ'))  arity(forces'(ψ))"
      using pred_mono[OF _  arity_ren_forces_nand] pred_succ_eq
      by simp_all
    from Nand
    have "3  arity(forces'(φ))  arity(φ) #+ 4"
      "3  arity(forces'(ψ))  arity(ψ) #+ 4"
      using Un_le by simp_all
    with Nand
    show "pred(arity(?φ'))  ?rhs"
      "pred(arity(?ψ'))  ?rhs"
      using le_trans[OF A(1)] le_trans[OF A(2)] le_Un_iff
      by simp_all
  qed
  with Nand _=4
  show ?case
    using pred_Un_distrib Un_assoc[symmetric] succ_Un_distrib nat_union_abs1 Un_leI3[OF 3  ?rhs]
    by simp
next
  case (Forall φ)
  let ?φ' = "ren_forces_forall(forces'(φ))"
  show ?case
  proof (cases "arity(φ) = 0")
    case True
    with Forall
    show ?thesis
    proof -
      from Forall True
      have "arity(forces'(φ))  5"
        using le_trans[of _ 4 5] by auto
      with φ_
      have "arity(?φ')  5"
        using arity_ren_forces_all[OF forces'_type[OF φ_]] nat_union_abs2
        by auto
      with Forall True
      show ?thesis
        using pred_mono[OF _ ‹arity(?φ')  5]
        by simp
    qed
  next
    case False
    with Forall
    show ?thesis
    proof -
      from Forall False
      have "arity(?φ') = 5  arity(forces'(φ))"
        "arity(forces'(φ))  5 #+ arity(φ)"
        "4  succ(succ(succ(arity(φ))))"
        using Ord_0_lt arity_ren_forces_all
          le_trans[OF _ add_le_mono[of 4 5, OF _ le_refl]]
        by auto
      with φ_
      have "5  arity(forces'(φ))  5#+arity(φ)"
        using nat_simp_union by auto
      with φ_ ‹arity(?φ') = 5  _
      show ?thesis
        using pred_Un_distrib succ_pred_eq[OF _ ‹arity(φ)0]
          pred_mono[OF _ Forall(2)] Un_le[OF 4succ(_)]
        by simp
    qed
  qed
qed

lemma arity_forces :
  assumes "φformula"
  shows "arity(forces(φ))  4#+arity(φ)"
  unfolding forces_def
  using assms arity_forces' le_trans nat_simp_union by auto

lemma arity_forces_le :
  assumes "φformula" "nnat" "arity(φ)  n"
  shows "arity(forces(φ))  4#+n"
  using assms le_trans[OF _ add_le_mono[OF le_refl[of 5] ‹arity(φ)_]] arity_forces
  by auto

end

Theory Forcing_Theorems

section‹The Forcing Theorems›

theory Forcing_Theorems
  imports
    Forces_Definition

begin

context forcing_data
begin

subsection‹The forcing relation in context›

abbreviation Forces :: "[i, i, i]  o"  ("_  _ _" [36,36,36] 60) where
  "p  φ env      M, ([p,P,leq,one] @ env)  forces(φ)"

lemma Collect_forces :
  assumes 
    fty: "φformula" and
    far: "arity(φ)length(env)" and
    envty: "envlist(M)"
  shows
    "{pP . p  φ env}  M"
proof -
  have "zP  zM" for z
    using P_in_M transitivity[of z P] by simp
  moreover
  have "separation(##M,λp. (p  φ env))"
        using separation_ax arity_forces far fty P_in_M leq_in_M one_in_M envty arity_forces_le
    by simp
  then 
  have "Collect(P,λp. (p  φ env))M"
    using separation_closed P_in_M by simp
  then show ?thesis by simp
qed

lemma forces_mem_iff_dense_below:  "pP  forces_mem(p,t1,t2)  dense_below(
    {qP. s. r. rP  s,r  t2  qr  forces_eq(q,t1,s)}
    ,p)"
  using def_forces_mem[of p t1 t2] by blast

subsection‹Kunen 2013, Lemma IV.2.37(a)›

lemma strengthening_eq:
  assumes "pP" "rP" "rp" "forces_eq(p,t1,t2)"
  shows "forces_eq(r,t1,t2)"
  using assms def_forces_eq[of _ t1 t2] leq_transD by blast
(* Long proof *)
(*
proof -
  {
    fix s q
    assume "q≼ r" "q∈P"
    with assms
    have "q≼p"
      using leq_preord unfolding preorder_on_def trans_on_def by blast
    moreover 
    note ‹q∈P› assms
    moreover
    assume "s∈domain(t1) ∪ domain(t2)" 
    ultimately
    have "forces_mem(q, s, t1) ⟷ forces_mem(q, s, t2)"
      using def_forces_eq[of p t1 t2] by simp
  }
  with ‹r∈P›
  show ?thesis using def_forces_eq[of r t1 t2] by blast
qed
*)

subsection‹Kunen 2013, Lemma IV.2.37(a)›
lemma strengthening_mem: 
  assumes "pP" "rP" "rp" "forces_mem(p,t1,t2)"
  shows "forces_mem(r,t1,t2)"
  using assms forces_mem_iff_dense_below dense_below_under by auto

subsection‹Kunen 2013, Lemma IV.2.37(b)›
lemma density_mem: 
  assumes "pP"
  shows "forces_mem(p,t1,t2)   dense_below({qP. forces_mem(q,t1,t2)},p)"
proof
  assume "forces_mem(p,t1,t2)"
  with assms
  show "dense_below({qP. forces_mem(q,t1,t2)},p)"
    using forces_mem_iff_dense_below strengthening_mem[of p] ideal_dense_below by auto
next
  assume "dense_below({q  P . forces_mem(q, t1, t2)}, p)"
  with assms
  have "dense_below({qP. 
    dense_below({q'P. s r. r  P  s,rt2  q'r  forces_eq(q',t1,s)},q)
    },p)"
    using forces_mem_iff_dense_below by simp
  with assms
  show "forces_mem(p,t1,t2)"
    using dense_below_dense_below forces_mem_iff_dense_below[of p t1 t2] by blast
qed

lemma aux_density_eq:
  assumes 
    "dense_below(
    {q'P. q. qP  qq'  forces_mem(q,s,t1)  forces_mem(q,s,t2)}
    ,p)"
    "forces_mem(q,s,t1)" "qP" "pP" "qp"
  shows
    "dense_below({rP. forces_mem(r,s,t2)},q)"
proof
  fix r
  assume "rP" "rq"
  moreover from this and pP qp qP
  have "rp"
    using leq_transD by simp
  moreover
  note ‹forces_mem(q,s,t1) ‹dense_below(_,p) qP
  ultimately
  obtain q1 where "q1r" "q1P" "forces_mem(q1,s,t2)"
    using strengthening_mem[of q _ s t1] leq_reflI leq_transD[of _ r q] by blast
  then
  show "d{r  P . forces_mem(r, s, t2)}. d  P  d r"
    by blast
qed

(* Kunen 2013, Lemma IV.2.37(b) *)
lemma density_eq:
  assumes "pP"
  shows "forces_eq(p,t1,t2)   dense_below({qP. forces_eq(q,t1,t2)},p)"
proof
  assume "forces_eq(p,t1,t2)"
  with pP
  show "dense_below({qP. forces_eq(q,t1,t2)},p)"
    using strengthening_eq ideal_dense_below by auto
next
  assume "dense_below({qP. forces_eq(q,t1,t2)},p)"
  {
    fix s q 
    let ?D1="{q'P. sdomain(t1)  domain(t2). q. q  P  qq' 
           forces_mem(q,s,t1)forces_mem(q,s,t2)}"
    let ?D2="{q'P. q. qP  qq'  forces_mem(q,s,t1)  forces_mem(q,s,t2)}"
    assume "sdomain(t1)  domain(t2)" 
    then
    have "?D1?D2" by blast
    with ‹dense_below(_,p)
    have "dense_below({q'P. sdomain(t1)  domain(t2). q. q  P  qq' 
           forces_mem(q,s,t1)forces_mem(q,s,t2)},p)"
      using dense_below_cong'[OF pP def_forces_eq[of _ t1 t2]] by simp
    with pP ?D1?D2
    have "dense_below({q'P. q. qP  qq'  
            forces_mem(q,s,t1)  forces_mem(q,s,t2)},p)"
      using dense_below_mono by simp
    moreover from this (* Automatic tools can't handle this symmetry 
                          in order to apply aux_density_eq below *)
    have  "dense_below({q'P. q. qP  qq'  
            forces_mem(q,s,t2)  forces_mem(q,s,t1)},p)"
      by blast
    moreover
    assume "q  P" "qp"
    moreover
    note pP
    ultimately (*We can omit the next step but it is slower *)
    have "forces_mem(q,s,t1)  dense_below({rP. forces_mem(r,s,t2)},q)"
         "forces_mem(q,s,t2)  dense_below({rP. forces_mem(r,s,t1)},q)" 
      using aux_density_eq by simp_all
    then
    have "forces_mem(q, s, t1)  forces_mem(q, s, t2)"
      using density_mem[OF qP] by blast
  }
  with pP
  show "forces_eq(p,t1,t2)" using def_forces_eq by blast
qed

subsection‹Kunen 2013, Lemma IV.2.38›
lemma not_forces_neq:
  assumes "pP"
  shows "forces_eq(p,t1,t2)  ¬ (qP. qp  forces_neq(q,t1,t2))"
  using assms density_eq unfolding forces_neq_def by blast


lemma not_forces_nmem:
  assumes "pP"
  shows "forces_mem(p,t1,t2)  ¬ (qP. qp  forces_nmem(q,t1,t2))"
  using assms density_mem unfolding forces_nmem_def by blast


(* Use the newer versions in Forces_Definition! *)
(* (and adequate the rest of the code to them)  *)

lemma sats_forces_Nand':
  assumes
    "pP" "φformula" "ψformula" "env  list(M)" 
  shows
    "M, [p,P,leq,one] @ env  forces(Nand(φ,ψ))  
     ¬(qM. qP  is_leq(##M,leq,q,p)  
           M, [q,P,leq,one] @ env  forces(φ)  
           M, [q,P,leq,one] @ env  forces(ψ))"
  using assms sats_forces_Nand[OF assms(2-4) transitivity[OF pP]]
  P_in_M leq_in_M one_in_M unfolding forces_def
  by simp

lemma sats_forces_Neg':
  assumes
    "pP" "env  list(M)" "φformula"
  shows
    "M, [p,P,leq,one] @ env  forces(Neg(φ))    
     ¬(qM. qP  is_leq(##M,leq,q,p)  
          M, [q,P,leq,one]@env  forces(φ))"
  using assms sats_forces_Neg transitivity 
  P_in_M leq_in_M one_in_M  unfolding forces_def
  by (simp, blast)

lemma sats_forces_Forall':
  assumes
    "pP" "env  list(M)" "φformula"
  shows
    "M,[p,P,leq,one] @ env  forces(Forall(φ))  
     (xM.   M, [p,P,leq,one,x] @ env  forces(φ))"
  using assms sats_forces_Forall transitivity 
  P_in_M leq_in_M one_in_M sats_ren_forces_forall unfolding forces_def
  by simp

subsection‹The relation of forcing and atomic formulas›
lemma Forces_Equal:
  assumes
    "pP" "t1M" "t2M" "envlist(M)" "nth(n,env) = t1" "nth(m,env) = t2" "nnat" "mnat" 
  shows
    "(p  Equal(n,m) env)  forces_eq(p,t1,t2)"
   using assms sats_forces_Equal forces_eq_abs transitivity P_in_M 
  by simp

lemma Forces_Member:
  assumes
    "pP" "t1M" "t2M" "envlist(M)" "nth(n,env) = t1" "nth(m,env) = t2" "nnat" "mnat" 
  shows
    "(p  Member(n,m) env)  forces_mem(p,t1,t2)"
   using assms sats_forces_Member forces_mem_abs transitivity P_in_M
  by simp

lemma Forces_Neg:
  assumes
    "pP" "env  list(M)" "φformula" 
  shows
    "(p  Neg(φ) env)  ¬(qM. qP  qp  (q  φ env))"
    using assms sats_forces_Neg' transitivity 
  P_in_M pair_in_M_iff leq_in_M leq_abs by simp
 
subsection‹The relation of forcing and connectives›

lemma Forces_Nand:
  assumes
    "pP" "env  list(M)" "φformula" "ψformula"
  shows
    "(p  Nand(φ,ψ) env)  ¬(qM. qP  qp  (q  φ env)  (q  ψ env))"
   using assms sats_forces_Nand' transitivity 
  P_in_M pair_in_M_iff leq_in_M leq_abs by simp

lemma Forces_And_aux:
  assumes
    "pP" "env  list(M)" "φformula" "ψformula"
  shows
    "p  And(φ,ψ) env    
    (qM. qP  qp  (rM. rP  rq  (r  φ env)  (r  ψ env)))"
  unfolding And_def using assms Forces_Neg Forces_Nand by (auto simp only:)

lemma Forces_And_iff_dense_below:
  assumes
    "pP" "env  list(M)" "φformula" "ψformula"
  shows
    "(p  And(φ,ψ) env)  dense_below({rP. (r  φ env)  (r  ψ env) },p)"
  unfolding dense_below_def using Forces_And_aux assms
    by (auto dest:transitivity[OF _ P_in_M]; rename_tac q; drule_tac x=q in bspec)+

lemma Forces_Forall:
  assumes
    "pP" "env  list(M)" "φformula"
  shows
    "(p  Forall(φ) env)  (xM. (p  φ ([x] @ env)))"
   using sats_forces_Forall' assms by simp

(* "x∈val(G,π) ⟹ ∃θ. ∃p∈G.  ⟨θ,p⟩∈π ∧ val(G,θ) = x" *)
bundle some_rules =  elem_of_val_pair [dest] SepReplace_iff [simp del] SepReplace_iff[iff]

context 
  includes some_rules
begin

lemma elem_of_valI: "θ. pP. pG  θ,pπ  val(G,θ) = x  xval(G,π)"
  by (subst def_val, auto)

lemma GenExtD: "xM[G]  (τM. x = val(G,τ))"
  unfolding GenExt_def by simp

lemma left_in_M : "tauM  a,btau  aM"
  using fst_snd_closed[of "a,b"] transitivity by auto


subsection‹Kunen 2013, Lemma IV.2.29›
lemma generic_inter_dense_below: 
  assumes "DM" "M_generic(G)" "dense_below(D,p)" "pG"
  shows "D  G  0"
proof -
  let ?D="{qP. pq  qD}"
  have "dense(?D)"
  proof
    fix r
    assume "rP"
    show "d{q  P . p  q  q  D}. d  r"
    proof (cases "p  r")
      case True
      with rP
        (* Automatic tools can't handle this case for some reason... *)
      show ?thesis using leq_reflI[of r] by (intro bexI) (blast+)
    next
      case False
      then
      obtain s where "sP" "sp" "sr" by blast
      with assms rP
      show ?thesis
        using dense_belowD[OF assms(3), of s] leq_transD[of _ s r]
        by blast
    qed
  qed
  have "?DP" by auto
  (* D∈M *)
  let ?d_fm="Or(Neg(compat_in_fm(1,2,3,0)),Member(0,4))"
  have 1:"pM" 
    using ‹M_generic(G) M_genericD transitivity[OF _ P_in_M]
          pG by simp
  moreover
  have "?d_fmformula" by simp
  moreover
  have "arity(?d_fm) = 5" unfolding compat_in_fm_def pair_fm_def upair_fm_def
    by (simp add: nat_union_abs1 Un_commute)
  moreover
  have "(M, [q,P,leq,p,D]  ?d_fm)  (¬ is_compat_in(##M,P,leq,p,q)  qD)"
    if "qM" for q
    using that sats_compat_in_fm P_in_M leq_in_M 1 DM by simp
  moreover
  have "(¬ is_compat_in(##M,P,leq,p,q)  qD)  pq  qD" if "qM" for q
    unfolding compat_def using that compat_in_abs P_in_M leq_in_M 1 by simp
  ultimately
  have "?DM" using Collect_in_M_4p[of ?d_fm _ _ _ _ _"λx y z w h. wx  xh"] 
                    P_in_M leq_in_M DM by simp
  note asm = ‹M_generic(G) ‹dense(?D) ?DP ?DM
  obtain x where "xG" "x?D" using M_generic_denseD[OF asm]
    by force (* by (erule bexE) does it, but the other automatic tools don't *)
  moreover from this and ‹M_generic(G)
  have "xD"
    using M_generic_compatD[OF _ pG, of x]
      leq_reflI compatI[of _ p x] by force
  ultimately
  show ?thesis by auto
qed

subsection‹Auxiliary results for Lemma IV.2.40(a)›
lemma IV240a_mem_Collect:
  assumes
    "πM" "τM"
  shows
    "{qP. σ. r. rP  σ,r  τ  qr  forces_eq(q,π,σ)}M"
proof -
  let ?rel_pred= "λM x a1 a2 a3 a4. σ[M]. r[M]. σr[M]. 
                ra1  pair(M,σ,r,σr)  σra4  is_leq(M,a2,x,r)  is_forces_eq'(M,a1,a2,x,a3,σ)"
  let ="Exists(Exists(Exists(And(Member(1,4),And(pair_fm(2,1,0),
          And(Member(0,7),And(leq_fm(5,3,1),forces_eq_fm(4,5,3,6,2))))))))" 
  have "σM  rM" if "σ, r  τ"  for σ r
    using that τM pair_in_M_iff transitivity[of "σ,r" τ] by simp
  then
  have "?rel_pred(##M,q,P,leq,π,τ)  (σ. r. rP  σ,r  τ  qr  forces_eq(q,π,σ))"
    if "qM" for q
    unfolding forces_eq_def using assms that P_in_M leq_in_M leq_abs forces_eq'_abs pair_in_M_iff 
    by auto
  moreover
  have "(M, [q,P,leq,π,τ]  )  ?rel_pred(##M,q,P,leq,π,τ)" if "qM" for q
    using assms that sats_forces_eq'_fm sats_leq_fm P_in_M leq_in_M by simp
  moreover
  have "formula" by simp
  moreover
  have "arity()=5" 
    unfolding leq_fm_def pair_fm_def upair_fm_def
    using arity_forces_eq_fm by (simp add:nat_simp_union Un_commute)
  ultimately
  show ?thesis 
    unfolding forces_eq_def using P_in_M leq_in_M assms 
        Collect_in_M_4p[of  _ _ _ _ _ 
            "λq a1 a2 a3 a4. σ. r. ra1  σ,r  τ  qr  forces_eq'(a1,a2,q,a3,σ)"] by simp
qed

(* Lemma IV.2.40(a), membership *)
lemma IV240a_mem:
  assumes
    "M_generic(G)" "pG" "πM" "τM" "forces_mem(p,π,τ)"
    "q σ. qP  qG  σdomain(τ)  forces_eq(q,π,σ)  
      val(G,π) = val(G,σ)" (* inductive hypothesis *)
  shows
    "val(G,π)val(G,τ)"
proof (intro elem_of_valI)
  let ?D="{qP. σ. r. rP  σ,r  τ  qr  forces_eq(q,π,σ)}"
  from ‹M_generic(G) pG
  have "pP" by blast
  moreover
  note πM τM
  ultimately
  have "?D  M" using IV240a_mem_Collect by simp
  moreover from assms pP
  have "dense_below(?D,p)"
    using forces_mem_iff_dense_below by simp
  moreover
  note ‹M_generic(G) pG
  ultimately
  obtain q where "qG" "q?D" using generic_inter_dense_below by blast
  then
  obtain σ r where "rP" "σ,r  τ" "qr" "forces_eq(q,π,σ)" by blast
  moreover from this and qG assms
  have "r  G" "val(G,π) = val(G,σ)" by blast+
  ultimately
  show " σ. pP. p  G  σ, p  τ  val(G, σ) = val(G, π)" by auto
qed

(* Example IV.2.36 (next two lemmas) *)
lemma refl_forces_eq:"pP  forces_eq(p,x,x)"
  using def_forces_eq by simp

lemma forces_memI: "σ,rτ  pP  rP  pr  forces_mem(p,σ,τ)"
  using refl_forces_eq[of _ σ] leq_transD leq_reflI 
  by (blast intro:forces_mem_iff_dense_below[THEN iffD2])

(* Lemma IV.2.40(a), equality, first inclusion *)
lemma IV240a_eq_1st_incl:
  assumes
    "M_generic(G)" "pG" "forces_eq(p,τ,θ)"
    and
    IH:"q σ. qP  qG  σdomain(τ)  domain(θ)  
        (forces_mem(q,σ,τ)  val(G,σ)  val(G,τ)) 
        (forces_mem(q,σ,θ)  val(G,σ)  val(G,θ))"
(* Strong enough for this case: *)
(*  IH:"⋀q σ. q∈P ⟹ σ∈domain(τ) ⟹ forces_mem(q,σ,θ) ⟹ 
      val(G,σ) ∈ val(G,θ)" *)
  shows
    "val(G,τ)  val(G,θ)"
proof
  fix x
  assume "xval(G,τ)"
  then
  obtain σ r where "σ,rτ" "rG" "val(G,σ)=x" by blast
  moreover from this and pG ‹M_generic(G)
  obtain q where "qG" "qp" "qr" by force
  moreover from this and pG ‹M_generic(G)
  have "qP" "pP" by blast+
  moreover from calculation and ‹M_generic(G)
  have "forces_mem(q,σ,τ)"
    using forces_memI by blast
  moreover
  note ‹forces_eq(p,τ,θ)
  ultimately
  have "forces_mem(q,σ,θ)"
    using def_forces_eq by blast
  with qP qG IH[of q σ] σ,rτ ‹val(G,σ) = x
  show "xval(G,θ)" by (blast)
qed

(* Lemma IV.2.40(a), equality, second inclusion--- COPY-PASTE *)
lemma IV240a_eq_2nd_incl:
  assumes
    "M_generic(G)" "pG" "forces_eq(p,τ,θ)"
    and
    IH:"q σ. qP  qG  σdomain(τ)  domain(θ)  
        (forces_mem(q,σ,τ)  val(G,σ)  val(G,τ)) 
        (forces_mem(q,σ,θ)  val(G,σ)  val(G,θ))"
  shows
    "val(G,θ)  val(G,τ)"
proof
  fix x
  assume "xval(G,θ)"
  then
  obtain σ r where "σ,rθ" "rG" "val(G,σ)=x" by blast
  moreover from this and pG ‹M_generic(G)
  obtain q where "qG" "qp" "qr" by force
  moreover from this and pG ‹M_generic(G)
  have "qP" "pP" by blast+
  moreover from calculation and ‹M_generic(G)
  have "forces_mem(q,σ,θ)"
    using forces_memI by blast
  moreover
  note ‹forces_eq(p,τ,θ)
  ultimately
  have "forces_mem(q,σ,τ)"
    using def_forces_eq by blast
  with qP qG IH[of q σ] σ,rθ ‹val(G,σ) = x
  show "xval(G,τ)" by (blast)
qed

(* Lemma IV.2.40(a), equality, second inclusion--- COPY-PASTE *)
lemma IV240a_eq:
  assumes
    "M_generic(G)" "pG" "forces_eq(p,τ,θ)"
    and
    IH:"q σ. qP  qG  σdomain(τ)  domain(θ)  
        (forces_mem(q,σ,τ)  val(G,σ)  val(G,τ)) 
        (forces_mem(q,σ,θ)  val(G,σ)  val(G,θ))"
  shows
    "val(G,τ) = val(G,θ)"
  using IV240a_eq_1st_incl[OF assms] IV240a_eq_2nd_incl[OF assms] IH by blast 

subsection‹Induction on names›

lemma core_induction:
  assumes
    "τ θ p. p  P  q σ. qP ; σdomain(θ)  Q(0,τ,σ,q)  Q(1,τ,θ,p)"
    "τ θ p. p  P  q σ. qP ; σdomain(τ)  domain(θ)  Q(1,σ,τ,q)  Q(1,σ,θ,q)  Q(0,τ,θ,p)"
    "ft  2" "p  P"
  shows
    "Q(ft,τ,θ,p)"
proof -
  {
    fix ft p τ θ
    have "Transset(eclose({τ,θ}))" (is "Transset(?e)") 
      using Transset_eclose by simp
    have "τ  ?e" "θ  ?e" 
      using arg_into_eclose by simp_all
    moreover
    assume "ft  2" "p  P"
    ultimately
    have "ft,τ,θ,p 2×?e×?e×P" (is "?a2×?e×?e×P") by simp
    then 
    have "Q(ftype(?a), name1(?a), name2(?a), cond_of(?a))"
      using core_induction_aux[of ?e P Q ?a,OF ‹Transset(?e) assms(1,2) ?a_] 
      by (clarify) (blast)
    then have "Q(ft,τ,θ,p)" by (simp add:components_simp)
  }
  then show ?thesis using assms by simp
qed

lemma forces_induction_with_conds:
  assumes
    "τ θ p. p  P  q σ. qP ; σdomain(θ)  Q(q,τ,σ)  R(p,τ,θ)"
    "τ θ p. p  P  q σ. qP ; σdomain(τ)  domain(θ)  R(q,σ,τ)  R(q,σ,θ)  Q(p,τ,θ)"
    "p  P"
  shows
    "Q(p,τ,θ)  R(p,τ,θ)"
proof -
  let ?Q="λft τ θ p. (ft = 0  Q(p,τ,θ))  (ft = 1  R(p,τ,θ))"
  from assms(1)
  have "τ θ p. p  P  q σ. qP ; σdomain(θ)  ?Q(0,τ,σ,q)  ?Q(1,τ,θ,p)"
    by simp
  moreover from assms(2)
  have "τ θ p. p  P  q σ. qP ; σdomain(τ)  domain(θ)  ?Q(1,σ,τ,q)  ?Q(1,σ,θ,q)  ?Q(0,τ,θ,p)"
    by simp
  moreover
  note pP
  ultimately
  have "?Q(ft,τ,θ,p)" if "ft2" for ft
    by (rule core_induction[OF _ _ that, of ?Q])
  then
  show ?thesis by auto
qed

lemma forces_induction:
  assumes
    "τ θ. σ. σdomain(θ)  Q(τ,σ)  R(τ,θ)"
    "τ θ. σ. σdomain(τ)  domain(θ)  R(σ,τ)  R(σ,θ)  Q(τ,θ)"
  shows
    "Q(τ,θ)  R(τ,θ)"
proof (intro forces_induction_with_conds[OF _ _ one_in_P ])
  fix τ θ p 
  assume "q  P  σ  domain(θ)  Q(τ, σ)" for q σ
  with assms(1)
  show "R(τ,θ)"
    using one_in_P by simp
next
  fix τ θ p 
    assume "q  P  σ  domain(τ)  domain(θ)  R(σ,τ)  R(σ,θ)" for q σ
    with assms(2)
    show "Q(τ,θ)"
      using one_in_P by simp
qed

subsection‹Lemma IV.2.40(a), in full›
lemma IV240a:
  assumes
    "M_generic(G)"
  shows 
    "(τM  θM  (pG. forces_eq(p,τ,θ)  val(G,τ) = val(G,θ)))  
     (τM  θM  (pG. forces_mem(p,τ,θ)  val(G,τ)  val(G,θ)))"
    (is "?Q(τ,θ)  ?R(τ,θ)")
proof (intro forces_induction[of ?Q ?R] impI)
  fix τ θ 
  assume "τM" "θM"  "σdomain(θ)  ?Q(τ,σ)" for σ
  moreover from this
  have "σdomain(θ)  forces_eq(q, τ, σ)  val(G, τ) = val(G, σ)" 
    if "qP" "qG" for q σ
    using that domain_closed[of θ] transitivity by auto
  moreover 
  note assms
  ultimately
  show "pG. forces_mem(p,τ,θ)  val(G,τ)  val(G,θ)"
    using IV240a_mem domain_closed transitivity by (simp)
next
  fix τ θ 
  assume "τM" "θM" "σ  domain(τ)  domain(θ)  ?R(σ,τ)  ?R(σ,θ)" for σ
  moreover from this
  have IH':"σ  domain(τ)  domain(θ)  qG 
            (forces_mem(q, σ, τ)  val(G, σ)  val(G, τ))  
            (forces_mem(q, σ, θ)  val(G, σ)  val(G, θ))" for q σ 
    by (auto intro:  transitivity[OF _ domain_closed[simplified]])
  ultimately
  show "pG. forces_eq(p,τ,θ)  val(G,τ) = val(G,θ)"
    using IV240a_eq[OF assms(1) _ _ IH'] by (simp)
qed

subsection‹Lemma IV.2.40(b)›
(* Lemma IV.2.40(b), membership *)
lemma IV240b_mem:
  assumes
    "M_generic(G)" "val(G,π)val(G,τ)" "πM" "τM"
    and
    IH:"σ. σdomain(τ)  val(G,π) = val(G,σ)  
      pG. forces_eq(p,π,σ)" (* inductive hypothesis *)
  shows
    "pG. forces_mem(p,π,τ)"
proof -
  from ‹val(G,π)val(G,τ)
  obtain σ r where "rG" "σ,rτ" "val(G,π) = val(G,σ)" by auto
  moreover from this and IH
  obtain p' where "p'G" "forces_eq(p',π,σ)" by blast
  moreover
  note ‹M_generic(G)
  ultimately
  obtain p where "pr" "pG" "forces_eq(p,π,σ)" 
    using M_generic_compatD strengthening_eq[of p'] by blast
  moreover 
  note ‹M_generic(G)
  moreover from calculation
  have "forces_eq(q,π,σ)" if "qP" "qp" for q
    using that strengthening_eq by blast
  moreover 
  note σ,rτ rG
  ultimately
  have "rP  σ,r  τ  qr  forces_eq(q,π,σ)" if "qP" "qp" for q
    using that leq_transD[of _ p r] by blast
  then
  have "dense_below({qP. s r. rP  s,r  τ  qr  forces_eq(q,π,s)},p)"
    using leq_reflI by blast
  moreover
  note ‹M_generic(G) pG
  moreover from calculation
  have "forces_mem(p,π,τ)" 
    using forces_mem_iff_dense_below by blast
  ultimately
  show ?thesis by blast
qed

end (* includes *)

lemma Collect_forces_eq_in_M:
  assumes "τ  M" "θ  M"
  shows "{pP. forces_eq(p,τ,θ)}  M"
  using assms Collect_in_M_4p[of "forces_eq_fm(1,2,0,3,4)" P leq τ θ 
                                  "λA x p l t1 t2. is_forces_eq(x,t1,t2)"
                                  "λ x p l t1 t2. forces_eq(x,t1,t2)" P] 
        arity_forces_eq_fm P_in_M leq_in_M sats_forces_eq_fm forces_eq_abs forces_eq_fm_type 
  by (simp add: nat_union_abs1 Un_commute)

lemma IV240b_eq_Collects:
  assumes "τ  M" "θ  M"
  shows "{pP. σdomain(τ)  domain(θ). forces_mem(p,σ,τ)  forces_nmem(p,σ,θ)}M" and
        "{pP. σdomain(τ)  domain(θ). forces_nmem(p,σ,τ)  forces_mem(p,σ,θ)}M"
proof -
  let ?rel_pred="λM x a1 a2 a3 a4. 
        σ[M]. u[M]. da3[M]. da4[M]. is_domain(M,a3,da3)  is_domain(M,a4,da4)  
          union(M,da3,da4,u)  σu  is_forces_mem'(M,a1,a2,x,σ,a3)  
          is_forces_nmem'(M,a1,a2,x,σ,a4)"
  let ="Exists(Exists(Exists(Exists(And(domain_fm(7,1),And(domain_fm(8,0),
          And(union_fm(1,0,2),And(Member(3,2),And(forces_mem_fm(5,6,4,3,7),
                              forces_nmem_fm(5,6,4,3,8))))))))))" 
  have 1:"σM" if "σ,yδ" "δM" for σ δ y
    using that pair_in_M_iff transitivity[of "σ,y" δ] by simp
  have abs1:"?rel_pred(##M,p,P,leq,τ,θ)  
        (σdomain(τ)  domain(θ). forces_mem'(P,leq,p,σ,τ)  forces_nmem'(P,leq,p,σ,θ))" 
        if "pM" for p
    unfolding forces_mem_def forces_nmem_def
    using assms that forces_mem'_abs forces_nmem'_abs P_in_M leq_in_M 
      domain_closed Un_closed 
    by (auto simp add:1[of _ _ τ] 1[of _ _ θ])
  have abs2:"?rel_pred(##M,p,P,leq,θ,τ)  (σdomain(τ)  domain(θ). 
        forces_nmem'(P,leq,p,σ,τ)  forces_mem'(P,leq,p,σ,θ))" if "pM" for p
    unfolding forces_mem_def forces_nmem_def
    using assms that forces_mem'_abs forces_nmem'_abs P_in_M leq_in_M 
      domain_closed Un_closed 
    by (auto simp add:1[of _ _ τ] 1[of _ _ θ])
  have fsats1:"(M,[p,P,leq,τ,θ]  )  ?rel_pred(##M,p,P,leq,τ,θ)" if "pM" for p
    using that assms sats_forces_mem'_fm sats_forces_nmem'_fm P_in_M leq_in_M
      domain_closed Un_closed by simp
  have fsats2:"(M,[p,P,leq,θ,τ]  )  ?rel_pred(##M,p,P,leq,θ,τ)" if "pM" for p
    using that assms sats_forces_mem'_fm sats_forces_nmem'_fm P_in_M leq_in_M
      domain_closed Un_closed by simp
  have fty:"formula" by simp
  have farit:"arity()=5"
    unfolding forces_nmem_fm_def domain_fm_def pair_fm_def upair_fm_def union_fm_def
    using arity_forces_mem_fm by (simp add:nat_simp_union Un_commute)
    show 
    "{p  P . σdomain(τ)  domain(θ). forces_mem(p, σ, τ)  forces_nmem(p, σ, θ)}  M"
    and "{p  P . σdomain(τ)  domain(θ). forces_nmem(p, σ, τ)  forces_mem(p, σ, θ)}  M"
    unfolding forces_mem_def
    using abs1 fty fsats1 farit P_in_M leq_in_M assms forces_nmem
          Collect_in_M_4p[of  _ _ _ _ _ 
          "λx p l a1 a2. (σdomain(a1)  domain(a2). forces_mem'(p,l,x,σ,a1)  
                                                     forces_nmem'(p,l,x,σ,a2))"]
    using abs2 fty fsats2 farit P_in_M leq_in_M assms forces_nmem domain_closed Un_closed
          Collect_in_M_4p[of  P leq θ τ ?rel_pred 
          "λx p l a2 a1. (σdomain(a1)  domain(a2). forces_nmem'(p,l,x,σ,a1)  
                                                     forces_mem'(p,l,x,σ,a2))" P]  
    by simp_all
qed

(* Lemma IV.2.40(b), equality *)
lemma IV240b_eq:
  assumes
    "M_generic(G)" "val(G,τ) = val(G,θ)" "τM" "θM" 
    and
    IH:"σ. σdomain(τ)domain(θ)  
      (val(G,σ)val(G,τ)  (qG. forces_mem(q,σ,τ)))  
      (val(G,σ)val(G,θ)  (qG. forces_mem(q,σ,θ)))"
    (* inductive hypothesis *)
  shows
    "pG. forces_eq(p,τ,θ)"
proof -
  let ?D1="{pP. forces_eq(p,τ,θ)}"
  let ?D2="{pP. σdomain(τ)  domain(θ). forces_mem(p,σ,τ)  forces_nmem(p,σ,θ)}"
  let ?D3="{pP. σdomain(τ)  domain(θ). forces_nmem(p,σ,τ)  forces_mem(p,σ,θ)}"
  let ?D="?D1  ?D2  ?D3"
  note assms
  moreover from this
  have "domain(τ)  domain(θ)M" (is "?BM") using domain_closed Un_closed by auto
  moreover from calculation
  have "?D2M" and "?D3M" using IV240b_eq_Collects by simp_all
  ultimately
  have "?DM" using Collect_forces_eq_in_M Un_closed by auto
  moreover
  have "dense(?D)"
  proof
    fix p
    assume "pP"
    have "dP. (forces_eq(d, τ, θ) 
            (σdomain(τ)  domain(θ). forces_mem(d, σ, τ)  forces_nmem(d, σ, θ)) 
            (σdomain(τ)  domain(θ). forces_nmem(d, σ, τ)  forces_mem(d, σ, θ))) 
           d  p" 
    proof (cases "forces_eq(p, τ, θ)")
      case True
      with pP 
      show ?thesis using leq_reflI by blast
    next
      case False
      moreover note pP
      moreover from calculation
      obtain σ q where "σdomain(τ)domain(θ)" "qP" "qp"
        "(forces_mem(q, σ, τ)  ¬ forces_mem(q, σ, θ)) 
         (¬ forces_mem(q, σ, τ)  forces_mem(q, σ, θ))"
        using def_forces_eq by blast
      moreover from this
      obtain r where "rq" "rP"
        "(forces_mem(r, σ, τ)  forces_nmem(r, σ, θ)) 
         (forces_nmem(r, σ, τ)  forces_mem(r, σ, θ))"
        using not_forces_nmem strengthening_mem by blast
      ultimately
      show ?thesis using leq_transD by blast
    qed
    then
    show "d?D1  ?D2  ?D3. d  p" by blast
  qed
  moreover
  have "?D  P"
    by auto
  moreover
  note ‹M_generic(G)
  ultimately
  obtain p where "pG" "p?D"
    unfolding M_generic_def by blast
  then 
  consider 
    (1) "forces_eq(p,τ,θ)" | 
    (2) "σdomain(τ)  domain(θ). forces_mem(p,σ,τ)  forces_nmem(p,σ,θ)" | 
    (3) "σdomain(τ)  domain(θ). forces_nmem(p,σ,τ)  forces_mem(p,σ,θ)"
    by blast
  then
  show ?thesis
  proof (cases)
    case 1
    with pG 
    show ?thesis by blast
  next
    case 2
    then 
    obtain σ where "σdomain(τ)  domain(θ)" "forces_mem(p,σ,τ)" "forces_nmem(p,σ,θ)" 
      by blast
    moreover from this and pG and assms
    have "val(G,σ)val(G,τ)"
      using IV240a[of G σ τ] transitivity[OF _ domain_closed[simplified]] by blast
    moreover note IH ‹val(G,τ) = _
    ultimately
    obtain q where "qG" "forces_mem(q, σ, θ)" by auto
    moreover from this and pG ‹M_generic(G)
    obtain r where "rP" "rp" "rq"
      by blast
    moreover
    note ‹M_generic(G)
    ultimately
    have "forces_mem(r, σ, θ)"
      using strengthening_mem by blast
    with rp ‹forces_nmem(p,σ,θ) rP
    have "False"
      unfolding forces_nmem_def by blast
    then
    show ?thesis by simp
  next (* copy-paste from case 2 mutatis mutandis*)
    case 3
    then
    obtain σ where "σdomain(τ)  domain(θ)" "forces_mem(p,σ,θ)" "forces_nmem(p,σ,τ)" 
      by blast
    moreover from this and pG and assms
    have "val(G,σ)val(G,θ)"
      using IV240a[of G σ θ] transitivity[OF _ domain_closed[simplified]] by blast
    moreover note IH ‹val(G,τ) = _
    ultimately
    obtain q where "qG" "forces_mem(q, σ, τ)" by auto
    moreover from this and pG ‹M_generic(G)
    obtain r where "rP" "rp" "rq"
      by blast
    moreover
    note ‹M_generic(G)
    ultimately
    have "forces_mem(r, σ, τ)"
      using strengthening_mem by blast
    with rp ‹forces_nmem(p,σ,τ) rP
    have "False"
      unfolding forces_nmem_def by blast
    then
    show ?thesis by simp
  qed
qed

(* Lemma IV.2.40(b), full *)
lemma IV240b:
  assumes
    "M_generic(G)"
  shows 
    "(τMθMval(G,τ) = val(G,θ)  (pG. forces_eq(p,τ,θ))) 
     (τMθMval(G,τ)  val(G,θ)  (pG. forces_mem(p,τ,θ)))" 
    (is "?Q(τ,θ)  ?R(τ,θ)")
proof (intro forces_induction)
  fix τ θ p
  assume "σdomain(θ)  ?Q(τ, σ)" for σ
  with assms
  show "?R(τ, θ)"
    using IV240b_mem domain_closed transitivity by (simp)
next
  fix τ θ p
  assume "σ  domain(τ)  domain(θ)  ?R(σ,τ)  ?R(σ,θ)" for σ
  moreover from this
  have IH':"τM  θM  σ  domain(τ)  domain(θ) 
          (val(G, σ)  val(G, τ)  (qG. forces_mem(q, σ, τ))) 
          (val(G, σ)  val(G, θ)  (qG. forces_mem(q, σ, θ)))" for σ 
    by (blast intro:left_in_M) 
  ultimately
  show "?Q(τ,θ)"
    using IV240b_eq[OF assms(1)] by (auto)
qed

lemma map_val_in_MG:
  assumes 
    "envlist(M)"
  shows 
    "map(val(G),env)list(M[G])"
  unfolding GenExt_def using assms map_type2 by simp

lemma truth_lemma_mem:
  assumes 
    "envlist(M)" "M_generic(G)"
    "nnat" "mnat" "n<length(env)" "m<length(env)"
  shows 
    "(pG. p  Member(n,m) env)    M[G], map(val(G),env)  Member(n,m)"
  using assms IV240a[OF assms(2), of "nth(n,env)" "nth(m,env)"] 
    IV240b[OF assms(2), of "nth(n,env)" "nth(m,env)"] 
    P_in_M leq_in_M one_in_M 
    Forces_Member[of _  "nth(n,env)" "nth(m,env)" env n m] map_val_in_MG
  by (auto)

lemma truth_lemma_eq:
  assumes 
    "envlist(M)" "M_generic(G)" 
    "nnat" "mnat" "n<length(env)" "m<length(env)"
  shows 
    "(pG. p  Equal(n,m) env)    M[G], map(val(G),env)  Equal(n,m)"
  using assms IV240a(1)[OF assms(2), of "nth(n,env)" "nth(m,env)"] 
    IV240b(1)[OF assms(2), of "nth(n,env)" "nth(m,env)"] 
    P_in_M leq_in_M one_in_M 
    Forces_Equal[of _  "nth(n,env)" "nth(m,env)" env n m] map_val_in_MG
  by (auto)

lemma arities_at_aux:
  assumes
    "n  nat" "m  nat" "env  list(M)" "succ(n)  succ(m)  length(env)"
  shows
    "n < length(env)" "m < length(env)"
  using assms succ_leE[OF Un_leD1, of n "succ(m)" "length(env)"] 
   succ_leE[OF Un_leD2, of "succ(n)" m "length(env)"] by auto

subsection‹The Strenghtening Lemma›

lemma strengthening_lemma:
  assumes 
    "pP" "φformula" "rP" "rp"
  shows
    "env. envlist(M)  arity(φ)length(env)  p  φ env  r  φ env"
  using assms(2)
proof (induct)
  case (Member n m)
  then
  have "n<length(env)" "m<length(env)"
    using arities_at_aux by simp_all
  moreover
  assume "envlist(M)"
  moreover
  note assms Member
  ultimately
  show ?case 
    using Forces_Member[of _ "nth(n,env)" "nth(m,env)" env n m]
      strengthening_mem[of p r "nth(n,env)" "nth(m,env)"] by simp
next
  case (Equal n m)
  then
  have "n<length(env)" "m<length(env)"
    using arities_at_aux by simp_all
  moreover
  assume "envlist(M)"
  moreover
  note assms Equal
  ultimately
  show ?case 
    using Forces_Equal[of _ "nth(n,env)" "nth(m,env)" env n m]
      strengthening_eq[of p r "nth(n,env)" "nth(m,env)"] by simp
next
  case (Nand φ ψ)
  with assms
  show ?case 
    using Forces_Nand transitivity[OF _ P_in_M] pair_in_M_iff 
      transitivity[OF _ leq_in_M] leq_transD by auto
next
  case (Forall φ)
  with assms
  have "p  φ ([x] @ env)" if "xM" for x
    using that Forces_Forall by simp
  with Forall 
  have "r  φ ([x] @ env)" if "xM" for x
    using that pred_le2 by (simp)
  with assms Forall
  show ?case 
    using Forces_Forall by simp
qed

subsection‹The Density Lemma›
lemma arity_Nand_le: 
  assumes "φ  formula" "ψ  formula" "arity(Nand(φ, ψ))  length(env)" "envlist(A)"
  shows "arity(φ)  length(env)" "arity(ψ)  length(env)"
  using assms 
  by (rule_tac Un_leD1, rule_tac [5] Un_leD2, auto)

lemma dense_below_imp_forces:
  assumes 
    "pP" "φformula"
  shows
    "env. envlist(M)  arity(φ)length(env) 
     dense_below({qP. (q  φ env)},p)  (p  φ env)"
  using assms(2)
proof (induct)
  case (Member n m)
  then
  have "n<length(env)" "m<length(env)"
    using arities_at_aux by simp_all
  moreover
  assume "envlist(M)"
  moreover
  note assms Member
  ultimately
  show ?case 
    using Forces_Member[of _ "nth(n,env)" "nth(m,env)" env n m]
      density_mem[of p "nth(n,env)" "nth(m,env)"] by simp
next
  case (Equal n m)
  then
  have "n<length(env)" "m<length(env)"
    using arities_at_aux by simp_all
  moreover
  assume "envlist(M)"
  moreover
  note assms Equal
  ultimately
  show ?case 
    using Forces_Equal[of _ "nth(n,env)" "nth(m,env)" env n m]
      density_eq[of p "nth(n,env)" "nth(m,env)"] by simp
next
case (Nand φ ψ)
  {  
    fix q
    assume "qM" "qP" "q p" "q  φ env"
    moreover 
    note Nand
    moreover from calculation
    obtain d where "dP" "d  Nand(φ, ψ) env" "d q"
      using dense_belowI by auto
    moreover from calculation
    have "¬(d ψ env)" if "d  φ env"
      using that Forces_Nand leq_reflI transitivity[OF _ P_in_M, of d] by auto
    moreover 
    note arity_Nand_le[of φ ψ]
    moreover from calculation
    have "d  φ env" 
       using strengthening_lemma[of q φ d env] Un_leD1 by auto
    ultimately
    have "¬ (q  ψ env)"
      using strengthening_lemma[of q ψ d env] by auto
  }
  with pP
  show ?case
    using Forces_Nand[symmetric, OF _ Nand(5,1,3)] by blast
next
  case (Forall φ)
  have "dense_below({qP. q  φ ([a]@env)},p)" if "aM" for a
  proof
    fix r
    assume "rP" "rp"
    with ‹dense_below(_,p)
    obtain q where "qP" "qr" "q  Forall(φ) env"
      by blast
    moreover
    note Forall aM
    moreover from calculation
    have "q  φ ([a]@env)"
      using Forces_Forall by simp
    ultimately
    show "d  {qP. q  φ ([a]@env)}. d  P  dr"
      by auto
  qed
  moreover 
  note Forall(2)[of "Cons(_,env)"] Forall(1,3-5)
  ultimately
  have "p  φ ([a]@env)" if "aM" for a
    using that pred_le2 by simp
  with assms Forall
  show ?case using Forces_Forall by simp
qed

lemma density_lemma:
  assumes
    "pP" "φformula" "envlist(M)" "arity(φ)length(env)"
  shows
    "p  φ env      dense_below({qP. (q  φ env)},p)"
proof
  assume "dense_below({qP. (q  φ env)},p)"
  with assms
  show  "(p  φ env)"
    using dense_below_imp_forces by simp
next
  assume "p  φ env"
  with assms
  show "dense_below({qP. q  φ env},p)"
    using strengthening_lemma leq_reflI by auto
qed

subsection‹The Truth Lemma›
lemma Forces_And:
  assumes
    "pP" "env  list(M)" "φformula" "ψformula" 
    "arity(φ)  length(env)" "arity(ψ)  length(env)"
  shows
    "p  And(φ,ψ) env     (p  φ env)  (p  ψ env)"
proof
  assume "p  And(φ, ψ) env"
  with assms
  have "dense_below({r  P . (r  φ env)  (r  ψ env)}, p)"
    using Forces_And_iff_dense_below by simp
  then
  have "dense_below({r  P . (r  φ env)}, p)" "dense_below({r  P . (r  ψ env)}, p)"
    by blast+
  with assms
  show "(p  φ env)  (p  ψ env)"
    using density_lemma[symmetric] by simp
next
  assume "(p  φ env)  (p  ψ env)"
  have "dense_below({r  P . (r  φ env)  (r  ψ env)}, p)"
  proof (intro dense_belowI bexI conjI, assumption)
    fix q
    assume "qP" "q p"
    with assms (p  φ env)  (p  ψ env)
    show "q{r  P . (r  φ env)  (r  ψ env)}" "q q"
      using strengthening_lemma leq_reflI by auto
  qed
  with assms
  show "p  And(φ,ψ) env"
    using Forces_And_iff_dense_below by simp
qed

lemma Forces_Nand_alt:
  assumes
    "pP" "env  list(M)" "φformula" "ψformula" 
    "arity(φ)  length(env)" "arity(ψ)  length(env)"
  shows
    "(p  Nand(φ,ψ) env)  (p  Neg(And(φ,ψ)) env)"
  using assms Forces_Nand Forces_And Forces_Neg by auto

lemma truth_lemma_Neg:
  assumes 
    "φformula" "M_generic(G)" "envlist(M)" "arity(φ)length(env)" and
    IH: "(pG. p  φ env)  M[G], map(val(G),env)  φ"
  shows
    "(pG. p  Neg(φ) env)    M[G], map(val(G),env)  Neg(φ)"
proof (intro iffI, elim bexE, rule ccontr) 
  (* Direct implication by contradiction *)
  fix p 
  assume "pG" "p  Neg(φ) env" "¬(M[G],map(val(G),env)  Neg(φ))"
  moreover 
  note assms
  moreover from calculation
  have "M[G], map(val(G),env)  φ"
    using map_val_in_MG by simp
  with IH
  obtain r where "r  φ env" "rG" by blast
  moreover from this and ‹M_generic(G) pG
  obtain q where "qp" "qr" "qG"
    by blast
  moreover from calculation 
  have "q  φ env"
    using strengthening_lemma[where φ=φ] by blast
  ultimately
  show "False"
    using Forces_Neg[where φ=φ] transitivity[OF _ P_in_M] by blast
next
  assume "M[G], map(val(G),env)  Neg(φ)"
  with assms 
  have "¬ (M[G], map(val(G),env)  φ)"
    using map_val_in_MG by simp
  let ?D="{pP. (p  φ env)  (p  Neg(φ) env)}"
  have "separation(##M,λp. (p  φ env))" 
      using separation_ax arity_forces assms P_in_M leq_in_M one_in_M arity_forces_le
    by simp
  moreover
  have "separation(##M,λp. (p  Neg(φ) env))"
      using separation_ax arity_forces assms P_in_M leq_in_M one_in_M arity_forces_le
    by simp
  ultimately
  have "separation(##M,λp. (p  φ env)  (p  Neg(φ) env))" 
    using separation_disj by simp
  then 
  have "?D  M" 
    using separation_closed P_in_M by simp
  moreover
  have "?D  P" by auto
  moreover
  have "dense(?D)"
  proof
    fix q
    assume "qP"
    show "d{p  P . (p  φ env)  (p  Neg(φ) env)}. d q"
    proof (cases "q  Neg(φ) env")
      case True
      with qP
      show ?thesis using leq_reflI by blast
    next
      case False
      with qP and assms
      show ?thesis using Forces_Neg by auto
    qed
  qed
  moreover
  note ‹M_generic(G)
  ultimately
  obtain p where "pG" "(p  φ env)  (p  Neg(φ) env)"
    by blast
  then
  consider (1) "p  φ env" | (2) "p  Neg(φ) env" by blast
  then
  show "pG. (p  Neg(φ) env)"
  proof (cases)
    case 1
    with ¬ (M[G],map(val(G),env)  φ) pG IH
    show ?thesis
      by blast
  next
    case 2
    with pG 
    show ?thesis by blast
  qed
qed 

lemma truth_lemma_And:
  assumes 
    "envlist(M)" "φformula" "ψformula"
    "arity(φ)length(env)" "arity(ψ)  length(env)" "M_generic(G)"
    and
    IH: "(pG. p  φ env)     M[G], map(val(G),env)  φ"
        "(pG. p  ψ env)     M[G], map(val(G),env)  ψ"
  shows
    "(pG. (p  And(φ,ψ) env))  M[G] , map(val(G),env)  And(φ,ψ)"
  using assms map_val_in_MG Forces_And[OF M_genericD assms(1-5)]
proof (intro iffI, elim bexE)
  fix p
  assume "pG" "p  And(φ,ψ) env"
  with assms
  show "M[G], map(val(G),env)  And(φ,ψ)" 
    using Forces_And[OF M_genericD, of _ _ _ φ ψ] map_val_in_MG by auto
next 
  assume "M[G], map(val(G),env)  And(φ,ψ)"
  moreover
  note assms
  moreover from calculation
  obtain q r where "q  φ env" "r  ψ env" "qG" "rG"
    using map_val_in_MG Forces_And[OF M_genericD assms(1-5)] by auto
  moreover from calculation
  obtain p where "pq" "pr" "pG"
    by blast
  moreover from calculation
  have "(p  φ env)  (p  ψ env)" (* can't solve as separate goals *)
    using strengthening_lemma by (blast)
  ultimately
  show "pG. (p  And(φ,ψ) env)"
    using Forces_And[OF M_genericD assms(1-5)] by auto
qed 

definition 
  ren_truth_lemma :: "ii" where
  "ren_truth_lemma(φ)  
    Exists(Exists(Exists(Exists(Exists(
    And(Equal(0,5),And(Equal(1,8),And(Equal(2,9),And(Equal(3,10),And(Equal(4,6),
    iterates(λp. incr_bv(p)`5 , 6, φ)))))))))))"

lemma ren_truth_lemma_type[TC] :
  "φformula  ren_truth_lemma(φ) formula" 
  unfolding ren_truth_lemma_def
  by simp

lemma arity_ren_truth : 
  assumes "φformula"
  shows "arity(ren_truth_lemma(φ))  6  succ(arity(φ))"
proof -
  consider (lt) "5 <arity(φ)" | (ge) "¬ 5 < arity(φ)"
    by auto
  then
  show ?thesis
  proof cases
    case lt
    consider (a) "5<arity(φ)#+5"  | (b) "arity(φ)#+5  5"
      using not_lt_iff_le φ_ by force
    then 
    show ?thesis
    proof cases
      case a
      with φ_ lt
      have "5 < succ(arity(φ))" "5<arity(φ)#+2"  "5<arity(φ)#+3"  "5<arity(φ)#+4"
        using succ_ltI by auto
       with φ_ 
      have c:"arity(iterates(λp. incr_bv(p)`5,5,φ)) = 5#+arity(φ)" (is "arity(?φ') = _") 
        using arity_incr_bv_lemma lt a
        by simp
      with φ_
      have "arity(incr_bv(?φ')`5) = 6#+arity(φ)"
        using arity_incr_bv_lemma[of ?φ' 5] a by auto
      with φ_
      show ?thesis
        unfolding ren_truth_lemma_def
        using pred_Un_distrib nat_union_abs1 Un_assoc[symmetric] a c nat_union_abs2
        by simp
    next
      case b
      with φ_ lt
      have "5 < succ(arity(φ))" "5<arity(φ)#+2"  "5<arity(φ)#+3"  "5<arity(φ)#+4" "5<arity(φ)#+5"
        using succ_ltI by auto
      with φ_ 
      have "arity(iterates(λp. incr_bv(p)`5,6,φ)) = 6#+arity(φ)" (is "arity(?φ') = _") 
        using arity_incr_bv_lemma lt 
        by simp
      with φ_
      show ?thesis
        unfolding ren_truth_lemma_def
        using pred_Un_distrib nat_union_abs1 Un_assoc[symmetric]  nat_union_abs2
        by simp
    qed
  next
    case ge
    with φ_
    have "arity(φ)  5" "pred^5(arity(φ))  5"
      using not_lt_iff_le le_trans[OF le_pred]
      by auto
    with φ_
    have "arity(iterates(λp. incr_bv(p)`5,6,φ)) = arity(φ)" "arity(φ)6" "pred^5(arity(φ))  6"
      using arity_incr_bv_lemma ge le_trans[OF ‹arity(φ)5] le_trans[OF ‹pred^5(arity(φ))5]
      by auto
    with ‹arity(φ)  5 φ_ ‹pred^5(_)  5
    show ?thesis
      unfolding ren_truth_lemma_def
      using  pred_Un_distrib nat_union_abs1 Un_assoc[symmetric] nat_union_abs2 
      by simp
  qed
qed

lemma sats_ren_truth_lemma:
  "[q,b,d,a1,a2,a3] @ env  list(M)  φ  formula 
   (M, [q,b,d,a1,a2,a3] @ env  ren_truth_lemma(φ) ) 
   (M, [q,a1,a2,a3,b] @ env  φ)"
  unfolding ren_truth_lemma_def
  by (insert sats_incr_bv_iff [of _ _ M _ "[q,a1,a2,a3,b]"], simp)

lemma truth_lemma' :
  assumes
    "φformula" "envlist(M)" "arity(φ)  succ(length(env))" 
  shows
    "separation(##M,λd. bM. qP. qd  ¬(q  φ ([b]@env)))"
proof -
  let ?rel_pred="λM x a1 a2 a3. bM. qM. qa1  is_leq(##M,a2,q,x)  
                  ¬(M, [q,a1,a2,a3,b] @ env  forces(φ))" 
  let ="Exists(Forall(Implies(And(Member(0,3),leq_fm(4,0,2)),
          Neg(ren_truth_lemma(forces(φ))))))"
  have "qM" if "qP" for q using that transitivity[OF _ P_in_M] by simp
  then
  have 1:"qM. qP  R(q)  Q(q)  (qP. R(q)  Q(q))" for R Q 
    by auto
  then
  have "b  M; qM. q  P  q  d  ¬(q  φ ([b]@env)) 
         cM. qP. q  d  ¬(q  φ ([c]@env))" for b d
    by (rule bexI,simp_all)
  then
  have "?rel_pred(M,d,P,leq,one)  (bM. qP. qd  ¬(q  φ ([b]@env)))" if "dM" for d
    using that leq_abs leq_in_M P_in_M one_in_M assms
    by auto
  moreover
  have "formula" using assms by simp
  moreover
  have "(M, [d,P,leq,one]@env  )  ?rel_pred(M,d,P,leq,one)" if "dM" for d
    using assms that P_in_M leq_in_M one_in_M sats_leq_fm sats_ren_truth_lemma
    by simp
  moreover
  have "arity()  4#+length(env)" 
  proof -
    have eq:"arity(leq_fm(4, 0, 2)) = 5"
      using arity_leq_fm succ_Un_distrib nat_simp_union
      by simp
    with φ_
    have "arity() = 3  (pred^2(arity(ren_truth_lemma(forces(φ)))))"
      using nat_union_abs1 pred_Un_distrib by simp
    moreover
    have "...  3  (pred(pred(6  succ(arity(forces(φ))))))" (is "_  ?r")
      using  φ_ Un_le_compat[OF le_refl[of 3]] 
                  le_imp_subset arity_ren_truth[of "forces(φ)"]
                  pred_mono
      by auto
    finally
    have "arity()  ?r" by simp
    have i:"?r  4  pred(arity(forces(φ)))" 
      using pred_Un_distrib pred_succ_eq φ_ Un_assoc[symmetric] nat_union_abs1 by simp
    have h:"4  pred(arity(forces(φ)))  4  (4#+length(env))"
      using  env_ add_commute φ_
            Un_le_compat[of 4 4,OF _ pred_mono[OF _ arity_forces_le[OF _ _ ‹arity(φ)_]] ]
            env_ by auto
    with φ_ env_
    show ?thesis
      using le_trans[OF  ‹arity()  ?r  le_trans[OF i h]] nat_simp_union by simp
  qed
  ultimately
  show ?thesis using assms P_in_M leq_in_M one_in_M 
       separation_ax[of "" "[P,leq,one]@env"] 
       separation_cong[of "##M" "λy. (M, [y,P,leq,one]@env )"]
    by simp
qed


lemma truth_lemma:
  assumes 
    "φformula" "M_generic(G)"
  shows 
     "env. envlist(M)  arity(φ)length(env)  
      (pG. p  φ env)      M[G], map(val(G),env)  φ"
  using assms(1)
proof (induct)
  case (Member x y)
  then
  show ?case
    using assms truth_lemma_mem[OF envlist(M) assms(2) xnat› ynat›] 
      arities_at_aux by simp
next
  case (Equal x y)
  then
  show ?case
    using assms truth_lemma_eq[OF envlist(M) assms(2) xnat› ynat›] 
      arities_at_aux by simp
next
  case (Nand φ ψ)
  moreover 
  note ‹M_generic(G)
  ultimately
  show ?case 
    using truth_lemma_And truth_lemma_Neg Forces_Nand_alt 
      M_genericD map_val_in_MG arity_Nand_le[of φ ψ] by auto
next
  case (Forall φ)
  with ‹M_generic(G)
  show ?case
  proof (intro iffI)
    assume "pG. (p  Forall(φ) env)"
    with ‹M_generic(G)
    obtain p where "pG" "pM" "pP" "p  Forall(φ) env"
      using transitivity[OF _ P_in_M] by auto
    with envlist(M) φformula›
    have "p  φ ([x]@env)" if "xM" for x
      using that Forces_Forall by simp
    with pG φformula› env_ ‹arity(Forall(φ))  length(env)
      Forall(2)[of "Cons(_,env)"] 
    show "M[G], map(val(G),env)   Forall(φ)"
      using pred_le2 map_val_in_MG
      by (auto iff:GenExtD)
  next
    assume "M[G], map(val(G),env)  Forall(φ)"
    let ?D1="{dP. (d  Forall(φ) env)}"
    let ?D2="{dP. bM. qP. qd  ¬(q  φ ([b]@env))}"
    define D where "D  ?D1  ?D2"
    have arφ:"arity(φ)succ(length(env))" 
      using assms ‹arity(Forall(φ))  length(env) φformula› envlist(M) pred_le2 
      by simp
    then
    have "arity(Forall(φ))  length(env)" 
      using pred_le φformula› envlist(M) by simp
    then
    have "?D1M" using Collect_forces arφ φformula› envlist(M) by simp
    moreover
    have "?D2M" using envlist(M) φformula›  truth_lemma' separation_closed arφ
                        P_in_M
      by simp
    ultimately
    have "DM" unfolding D_def using Un_closed by simp
    moreover
    have "D  P" unfolding D_def by auto
    moreover
    have "dense(D)" 
    proof
      fix p
      assume "pP"
      show "dD. d p"
      proof (cases "p  Forall(φ) env")
        case True
        with pP 
        show ?thesis unfolding D_def using leq_reflI by blast
      next
        case False
        with Forall pP
        obtain b where "bM" "¬(p  φ ([b]@env))"
          using Forces_Forall by blast
        moreover from this pP Forall
        have "¬dense_below({qP. q  φ ([b]@env)},p)"
          using density_lemma pred_le2  by auto
        moreover from this
        obtain d where "dp" "qP. qd  ¬(q  φ ([b] @ env))"
          "dP" by blast
        ultimately
        show ?thesis unfolding D_def by auto
      qed
    qed
    moreover
    note ‹M_generic(G)
    ultimately
    obtain d where "d  D"  "d  G" by blast
    then
    consider (1) "d?D1" | (2) "d?D2" unfolding D_def by blast
    then
    show "pG. (p  Forall(φ) env)"
    proof (cases)
      case 1
      with dG
      show ?thesis by blast
    next
      case 2
      then
      obtain b where "bM" "qP. qd ¬(q  φ ([b] @ env))"
        by blast
      moreover from this(1) and  M[G], _   Forall(φ) and 
        Forall(2)[of "Cons(b,env)"] Forall(1,3-4) ‹M_generic(G)
      obtain p where "pG" "pP" "p  φ ([b] @ env)" 
        using pred_le2 using map_val_in_MG by (auto iff:GenExtD)
      moreover
      note dG ‹M_generic(G)
      ultimately
      obtain q where "qG" "qP" "qd" "qp" by blast
      moreover from this and  p  φ ([b] @ env) 
        Forall  bM pP
      have "q  φ ([b] @ env)"
        using pred_le2 strengthening_lemma by simp
      moreover 
      note qP. qd ¬(q  φ ([b] @ env))
      ultimately
      show ?thesis by simp
    qed
  qed
qed
subsection‹The ``Definition of forcing''›
lemma definition_of_forcing:
  assumes
    "pP" "φformula" "envlist(M)" "arity(φ)length(env)"
  shows
    "(p  φ env) 
     (G. M_generic(G)  pG    M[G], map(val(G),env)  φ)"
proof (intro iffI allI impI, elim conjE)
  fix G
  assume "(p  φ env)" "M_generic(G)" "p  G"
  with assms 
  show "M[G], map(val(G),env)  φ"
    using truth_lemma by blast
next
  assume 1: "G.(M_generic(G) pG) M[G] , map(val(G),env)  φ"
  {
    fix r 
    assume 2: "rP" "rp"
    then 
    obtain G where "rG" "M_generic(G)"
      using generic_filter_existence by auto
    moreover from calculation 2 pP 
    have "pG" 
      unfolding M_generic_def using filter_leqD by simp
    moreover note 1
    ultimately
    have "M[G], map(val(G),env)  φ"
      by simp
    with assms ‹M_generic(G) 
    obtain s where "sG" "(s  φ env)"
      using truth_lemma by blast
    moreover from this and  ‹M_generic(G) rG 
    obtain q where "qG" "qs" "qr"
      by blast
    moreover from calculation sG ‹M_generic(G) 
    have "sP" "qP" 
      unfolding M_generic_def filter_def by auto
    moreover 
    note assms
    ultimately 
    have "qP. qr  (q  φ env)"
      using strengthening_lemma by blast
  }
  then
  have "dense_below({qP. (q  φ env)},p)"
    unfolding dense_below_def by blast
  with assms
  show "(p  φ env)"
    using density_lemma by blast
qed

lemmas definability = forces_type 
end (* forcing_data *)

end

Theory Separation_Rename

section‹Auxiliary renamings for Separation›
theory Separation_Rename
  imports Interface Renaming
begin

lemmas apply_fun = apply_iff[THEN iffD1]

lemma nth_concat : "[p,t]  list(A)  env list(A)  nth(1 #+ length(env),[p]@ env @ [t]) = t"
  by(auto simp add:nth_append)

lemma nth_concat2 : "env list(A)  nth(length(env),env @ [p,t]) = p"
  by(auto simp add:nth_append)

lemma nth_concat3 : "env list(A)  u = nth(succ(length(env)), env @ [pi, u])"
  by(auto simp add:nth_append)

definition 
  sep_var :: "i  i" where
  "sep_var(n)  {0,1,1,3,2,4,3,5,4,0,5#+n,6,6#+n,2}"

definition
  sep_env :: "i  i" where
  "sep_env(n)  λ i  (5#+n)-5 . i#+2"

definition weak :: "[i, i]  i" where
  "weak(n,m)  {i#+m . i  n}"

lemma weakD : 
  assumes "n  nat" "knat" "x  weak(n,k)"
  shows " i  n . x = i#+k"
  using assms unfolding weak_def by blast

lemma weak_equal :
  assumes "nnat" "mnat"
  shows "weak(n,m) = (m#+n) - m"
proof -
  have "weak(n,m)(m#+n)-m" 
  proof(intro subsetI)
    fix x
    assume "xweak(n,m)"
    with assms 
    obtain i where
      "in" "x=i#+m"
      using weakD by blast
    then
    have "mi#+m" "i<n"
      using add_le_self2[of m i] mnat› nnat› ltI[OF in] by simp_all
    then
    have "¬i#+m<m"
      using not_lt_iff_le in_n_in_nat[OF nnat› in] mnat› by simp
    with x=i#+m
    have "xm" 
      using ltI mnat› by auto
    moreover
    from assms x=i#+m i<n
    have "x<m#+n"
      using add_lt_mono1[OF i<n nnat›] by simp
    ultimately
    show "x(m#+n)-m" 
      using ltD DiffI by simp
  qed
  moreover
  have "(m#+n)-mweak(n,m)" 
  proof (intro subsetI)
    fix x 
    assume "x(m#+n)-m"
    then 
    have "xm#+n" "xm"
      using DiffD1[of x "n#+m" m] DiffD2[of x "n#+m" m] by simp_all
    then
    have "x<m#+n" "xnat" 
      using ltI in_n_in_nat[OF add_type[of m n]] by simp_all
    then
    obtain i where
      "m#+n = succ(x#+i)" 
      using less_iff_succ_add[OF xnat›,of "m#+n"] add_type by auto
    then 
    have "x#+i<m#+n" using succ_le_iff by simp
    with xm 
    have "¬x<m" using ltD by blast
    with mnat› xnat›
    have "mx" using not_lt_iff_le by simp 
    with x<m#+n  nnat›
    have "x#-m<m#+n#-m" 
      using diff_mono[OF xnat› _ mnat›] by simp
    have "m#+n#-m =  n" using diff_cancel2 mnat› nnat› by simp   
    with x#-m<m#+n#-m xnat›
    have "x#-m  n" "x=x#-m#+m" 
      using ltD add_diff_inverse2[OF mx] by simp_all
    then 
    show "xweak(n,m)" 
      unfolding weak_def by auto
  qed
  ultimately
  show ?thesis by auto
qed

lemma weak_zero:
  shows "weak(0,n) = 0"
  unfolding weak_def by simp

lemma weakening_diff :
  assumes "n  nat"
  shows "weak(n,7) - weak(n,5)  {5#+n, 6#+n}"
  unfolding weak_def using assms
proof(auto)
  {
    fix i
    assume "in" "succ(succ(natify(i)))n" "wn. succ(succ(natify(i)))  natify(w)"
    then 
    have "i<n" 
      using ltI nnat› by simp
    from nnat› in ‹succ(succ(natify(i)))n
    have "inat" "succ(succ(i))n" using in_n_in_nat by simp_all
    from i<n
    have "succ(i)n" using succ_leI by simp
    with nnat›
    consider (a) "succ(i) = n" | (b) "succ(i) < n"
      using leD by auto
    then have "succ(i) = n" 
    proof cases
      case a
      then show ?thesis .
    next
      case b
      then 
      have "succ(succ(i))n" using succ_leI by simp
      with nnat›
      consider (a) "succ(succ(i)) = n" | (b) "succ(succ(i)) < n"
        using leD by auto
      then have "succ(i) = n" 
      proof cases
        case a
        with ‹succ(succ(i))n show ?thesis by blast
      next
        case b
        then 
        have "succ(succ(i))n" using ltD by simp
        with inat›
        have "succ(succ(natify(i)))  natify(succ(succ(i)))"
          using  wn. succ(succ(natify(i)))  natify(w) by auto
        then 
        have "False" using inat› by auto
        then show ?thesis by blast
      qed
      then show ?thesis .
    qed
    with inat› have "succ(natify(i)) = n" by simp
  }
  then 
  show "n  nat  
    succ(succ(natify(y)))  n  
    xn. succ(succ(natify(y)))  natify(x) 
    y  n  succ(natify(y)) = n" for y
    by blast
qed

lemma in_add_del :
  assumes "xj#+n" "nnat" "jnat"
  shows "x < j  x  weak(n,j)" 
proof (cases "x<j")
  case True
  then show ?thesis ..
next
  case False
  have "xnat" "j#+nnat"
    using in_n_in_nat[OF _ xj#+n] assms by simp_all
  then
  have "j  x" "x < j#+n" 
    using not_lt_iff_le False jnat› nnat› ltI[OF xj#+n] by auto
  then 
  have "x#-j < (j #+ n) #- j" "x = j #+ (x #-j)"
    using diff_mono xnat› j#+nnat› jnat› nnat› 
      add_diff_inverse[OF jx] by simp_all
  then 
  have "x#-j < n" "x = (x #-j ) #+ j"
    using diff_add_inverse nnat› add_commute by simp_all
  then 
  have "x#-j n" using ltD by simp
  then 
  have "x  weak(n,j)" 
    unfolding weak_def
    using x= (x#-j) #+j RepFunI[OF x#-jn] add_commute by force
  then show ?thesis  ..
qed


lemma sep_env_action:
  assumes
    "[t,p,u,P,leq,o,pi]  list(M)"
    "env  list(M)"
  shows " i . i  weak(length(env),5)  
      nth(sep_env(length(env))`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])"
proof -
  from assms
  have A: "5#+length(env)nat" "[p, P, leq, o, t] list(M)"
    by simp_all
  let ?f="sep_env(length(env))"
  have EQ: "weak(length(env),5) = 5#+length(env) - 5"
    using weak_equal length_type[OF envlist(M)] by simp
  let ?tgt="[t,p,u,P,leq,o,pi]@env"
  let ?src="[p,P,leq,o,t] @ env @ [pi,u]"
  have "nth(?f`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])" 
    if "i  (5#+length(env)-5)" for i 
  proof -
    from that 
    have 2: "i  5#+length(env)"  "i  5" "i  nat" "i#-5nat" "i#+2nat"
      using in_n_in_nat[OF 5#+length(env)nat›] by simp_all
    then 
    have 3: "¬ i < 5" using ltD by force
    then
    have "5  i" "2  5" 
      using  not_lt_iff_le inat› by simp_all
    then have "2  i" using le_trans[OF 25] by simp
    from A i  5#+length(env) 
    have "i < 5#+length(env)" using ltI by simp
    with inat› 2i A
    have C:"i#+2 < 7#+length(env)"  by simp
    with that 
    have B: "?f`i = i#+2" unfolding sep_env_def by simp
    from 3 assms(1) inat›
    have "¬ i#+2 < 7" using not_lt_iff_le add_le_mono by simp
    from i < 5#+length(env) 3 inat›
    have "i#-5 < 5#+length(env) #- 5" 
      using diff_mono[of i "5#+length(env)" 5,OF _ _ _ i < 5#+length(env)] 
        not_lt_iff_le[THEN iffD1] by force
    with assms(2)
    have "i#-5 < length(env)" using diff_add_inverse length_type by simp
    have "nth(i,?src) =nth(i#-5,env@[pi,u])"
      using nth_append[OF A(2) inat›] 3 by simp
    also 
    have "... = nth(i#-5, env)" 
      using nth_append[OF env list(M) i#-5nat›] i#-5 < length(env) by simp
    also 
    have "... = nth(i#+2, ?tgt)"
      using nth_append[OF assms(1) i#+2nat›] ¬ i#+2 <7 by simp
    ultimately 
    have "nth(i,?src) = nth(?f`i,?tgt)"
      using B by simp 
    then show ?thesis using that by simp
  qed
  then show ?thesis using EQ by force
qed

lemma sep_env_type :
  assumes "n  nat"
  shows "sep_env(n) : (5#+n)-5  (7#+n)-7"
proof -
  let ?h="sep_env(n)"
  from nnat› 
  have "(5#+n)#+2 = 7#+n" "7#+nnat" "5#+nnat" by simp_all
  have
    D: "sep_env(n)`x  (7#+n)-7" if "x  (5#+n)-5" for x
  proof -
    from x5#+n-5
    have "?h`x = x#+2" "x<5#+n" "xnat"
      unfolding sep_env_def using ltI in_n_in_nat[OF 5#+nnat›] by simp_all
    then 
    have "x#+2 < 7#+n" by simp
    then 
    have "x#+2  7#+n" using ltD by simp
    from x5#+n-5
    have "x5" by simp 
    then have "¬x<5" using ltD by blast
    then have "5x" using not_lt_iff_le xnat› by simp
    then have "7x#+2" using add_le_mono xnat› by simp
    then have "¬x#+2<7" using not_lt_iff_le xnat› by simp
    then have "x#+2  7" using ltI xnat› by force
    with x#+2  7#+n show ?thesis using  ?h`x = x#+2 DiffI by simp
  qed
  then show ?thesis unfolding sep_env_def using lam_type by simp
qed

lemma sep_var_fin_type :
  assumes "n  nat"
  shows "sep_var(n) : 7#+n  -||> 7#+n"
  unfolding sep_var_def 
  using consI ltD emptyI by force

lemma sep_var_domain :
  assumes "n  nat"
  shows "domain(sep_var(n)) =  7#+n - weak(n,5)"
proof - 
  let ?A="weak(n,5)"
  have A:"domain(sep_var(n))  (7#+n)" 
    unfolding sep_var_def 
    by(auto simp add: le_natE)
  have C: "x=5#+n  x=6#+n  x  4" if "xdomain(sep_var(n))" for x
    using that unfolding sep_var_def by auto
  have D : "x<n#+7" if "x7#+n" for x
    using that nnat› ltI by simp
  have "¬ 5#+n < 5#+n" using nnat›  lt_irrefl[of _ False] by force
  have "¬ 6#+n < 5#+n" using nnat› by force
  have R: "x < 5#+n" if "x?A" for x
  proof -
    from that
    obtain i where
      "i<n" "x=5#+i" 
      unfolding weak_def
      using ltI nnat› RepFun_iff by force
    with nnat›
    have "5#+i < 5#+n" using add_lt_mono2 by simp
    with x=5#+i 
    show "x < 5#+n" by simp
  qed
  then 
  have 1:"x?A" if "¬x <5#+n" for x using that by blast
  have "5#+n  ?A" "6#+n?A"
  proof -
    show "5#+n  ?A" using 1 ¬5#+n<5#+n by blast    
    with 1 show "6#+n  ?A" using  ¬6#+n<5#+n by blast
  qed
  then 
  have E:"x?A" if "xdomain(sep_var(n))" for x 
    unfolding weak_def
    using C that by force
  then 
  have F: "domain(sep_var(n))  7#+n - ?A" using A by auto
  from assms
  have "x<7  xweak(n,7)" if "x7#+n" for x
    using in_add_del[OF x7#+n] by simp
  moreover
  {
    fix x
    assume asm:"x7#+n"  "x?A"  "xweak(n,7)"
    then 
    have "xdomain(sep_var(n))" 
    proof -
      from nnat›
      have "weak(n,7)-weak(n,5){n#+5,n#+6}" 
        using weakening_diff by simp
      with  x?A asm
      have "x{n#+5,n#+6}" using  subsetD DiffI by blast
      then 
      show ?thesis unfolding sep_var_def by simp
    qed
  }
  moreover
  {
    fix x
    assume asm:"x7#+n"  "x?A" "x<7"
    then have "xdomain(sep_var(n))"
    proof (cases "2  n")
      case True
      moreover
      have "0<n" using  leD[OF nnat› 2n] lt_imp_0_lt by auto
      ultimately
      have "x<5"
        using x<7 x?A nnat› in_n_in_nat
        unfolding weak_def
        by (clarsimp simp add:not_lt_iff_le, auto simp add:lt_def)
      then
      show ?thesis unfolding sep_var_def 
        by (clarsimp simp add:not_lt_iff_le, auto simp add:lt_def)
    next
      case False 
      then 
      show ?thesis 
      proof (cases "n=0")
        case True
        then show ?thesis 
          unfolding sep_var_def using ltD asm nnat› by auto
      next
        case False
        then 
        have "n < 2" using  nnat› not_lt_iff_le ¬ 2  n  by force
        then 
        have "¬ n <1" using n0 by simp
        then 
        have "n=1" using not_lt_iff_le n<2 le_iff by auto
        then show ?thesis 
          using x?A 
          unfolding weak_def sep_var_def 
          using ltD asm nnat› by force
      qed
    qed
  }
  ultimately
  have "wdomain(sep_var(n))" if "w 7#+n - ?A" for w
    using that by blast
  then
  have "7#+n - ?A  domain(sep_var(n))" by blast
  with F 
  show ?thesis by auto
qed

lemma sep_var_type :
  assumes "n  nat"
  shows "sep_var(n) : (7#+n)-weak(n,5)  7#+n"
  using FiniteFun_is_fun[OF sep_var_fin_type[OF nnat›]]
    sep_var_domain[OF nnat›] by simp

lemma sep_var_action :
  assumes 
    "[t,p,u,P,leq,o,pi]  list(M)"
    "env  list(M)"
  shows " i . i  (7#+length(env)) - weak(length(env),5)  
    nth(sep_var(length(env))`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])"
  using assms
proof (subst sep_var_domain[OF length_type[OF envlist(M)],symmetric],auto)
  fix i y
  assume "i, y  sep_var(length(env))"
  with assms
  show "nth(sep_var(length(env)) ` i,
               Cons(t, Cons(p, Cons(u, Cons(P, Cons(leq, Cons(o, Cons(pi, env)))))))) =
           nth(i, Cons(p, Cons(P, Cons(leq, Cons(o, Cons(t, env @ [pi, u]))))))"  
    using apply_fun[OF sep_var_type] assms
      unfolding sep_var_def
      using nth_concat2[OF envlist(M)]  nth_concat3[OF envlist(M),symmetric]
      by force
  qed

definition
  rensep :: "i  i" where
  "rensep(n)  union_fun(sep_var(n),sep_env(n),7#+n-weak(n,5),weak(n,5))"

lemma rensep_aux :
  assumes "nnat"
  shows "(7#+n-weak(n,5))  weak(n,5) = 7#+n" "7#+n  ( 7 #+ n - 7) = 7#+n"
proof -
  from nnat›
  have "weak(n,5) = n#+5-5"
    using weak_equal by simp
  with  nnat›
  show "(7#+n-weak(n,5))  weak(n,5) = 7#+n" "7#+n  ( 7 #+ n - 7) = 7#+n"
    using Diff_partition le_imp_subset by auto
qed

lemma rensep_type :
  assumes "nnat"
  shows "rensep(n)  7#+n  7#+n"
proof -
  from nnat›
  have "rensep(n)  (7#+n-weak(n,5))  weak(n,5)  7#+n  (7#+n - 7)"
    unfolding rensep_def 
    using union_fun_type  sep_var_type nnat› sep_env_type weak_equal
    by force
  then
  show ?thesis using rensep_aux nnat› by auto 
qed

lemma rensep_action :
  assumes "[t,p,u,P,leq,o,pi] @ env  list(M)"
  shows " i . i < 7#+length(env)  nth(rensep(length(env))`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])"
proof - 
  let ?tgt="[t,p,u,P,leq,o,pi]@env"
  let ?src="[p,P,leq,o,t] @ env @ [pi,u]"
  let ?m="7 #+ length(env) - weak(length(env),5)"
  let ?p="weak(length(env),5)"
  let ?f="sep_var(length(env))"
  let ?g="sep_env(length(env))"
  let ?n="length(env)"
  from assms
  have 1 : "[t,p,u,P,leq,o,pi]  list(M)" " env  list(M)"
    "?src  list(M)" "?tgt  list(M)"  
    "7#+?n = (7#+?n-weak(?n,5))  weak(?n,5)"
    " length(?src) = (7#+?n-weak(?n,5))  weak(?n,5)"
    using Diff_partition le_imp_subset rensep_aux by auto
  then
  have "nth(i, ?src) = nth(union_fun(?f, ?g, ?m, ?p) ` i, ?tgt)" if "i < 7#+length(env)" for i
  proof -
    from i<7#+?n
    have "i  (7#+?n-weak(?n,5))  weak(?n,5)" 
      using ltD by simp 
    then show ?thesis
      unfolding rensep_def using  
        union_fun_action[OF ?srclist(M) ?tgtlist(M) ‹length(?src) = (7#+?n-weak(?n,5))  weak(?n,5)
          sep_var_action[OF [t,p,u,P,leq,o,pi]  list(M) envlist(M)]      
          sep_env_action[OF [t,p,u,P,leq,o,pi]  list(M) envlist(M)]
          ] that 
      by simp
  qed
  then show ?thesis unfolding rensep_def by simp
qed

definition sep_ren :: "[i,i]  i" where
  "sep_ren(n,φ)  ren(φ)`(7#+n)`(7#+n)`rensep(n)"

lemma arity_rensep: assumes "φformula" "env  list(M)"
  "arity(φ)  7#+length(env)"
shows "arity(sep_ren(length(env),φ))  7#+length(env)"
  unfolding sep_ren_def
  using arity_ren rensep_type assms
  by simp

lemma type_rensep [TC]: 
  assumes "φformula" "envlist(M)" 
  shows "sep_ren(length(env),φ)  formula"
  unfolding sep_ren_def
  using ren_tc rensep_type assms
  by simp

lemma sepren_action: 
  assumes "arity(φ)  7 #+ length(env)"
    "[t,p,u,P,leq,o,pi]  list(M)"
    "envlist(M)"
    "φformula"
  shows "sats(M, sep_ren(length(env),φ),[t,p,u,P,leq,o,pi] @ env)  sats(M, φ,[p,P,leq,o,t] @ env @ [pi,u])"
proof -
  from assms
  have 1: " [t, p, u, P, leq, o, pi] @ env  list(M)" 
    "[P,leq,o,p,t]  list(M)"
    "[pi,u]  list(M)"    
    by simp_all
  then 
  have 2: "[p,P,leq,o,t] @ env @ [pi,u]  list(M)" using app_type by simp
  show ?thesis 
    unfolding sep_ren_def
    using sats_iff_sats_ren[OF φformula›       
        add_type[of 7 "length(env)"]
        add_type[of 7 "length(env)"]
        2 1(1) 
        rensep_type[OF length_type[OF envlist(M)]] 
        ‹arity(φ)  7 #+ length(env)]
      rensep_action[OF 1(1),rule_format,symmetric]
    by simp
qed

end

Theory Separation_Axiom

section‹The Axiom of Separation in $M[G]$›
theory Separation_Axiom
  imports Forcing_Theorems Separation_Rename
begin

context G_generic
begin

lemma map_val :
  assumes "envlist(M[G])"
  shows "nenvlist(M). env = map(val(G),nenv)"
  using assms
  proof(induct env)
    case Nil
    have "map(val(G),Nil) = Nil" by simp
    then show ?case by force
  next
    case (Cons a l)
    then obtain a' l' where
      "l'  list(M)" "l=map(val(G),l')" "a = val(G,a')"
      "Cons(a,l) = map(val(G),Cons(a',l'))" "Cons(a',l')  list(M)"
      using aM[G] GenExtD
      by force
    then show ?case by force
qed


lemma Collect_sats_in_MG :
  assumes
    "cM[G]"
    "φ  formula" "envlist(M[G])" "arity(φ)  1 #+ length(env)"
  shows    
    "{xc. (M[G], [x] @ env  φ)} M[G]"
proof -  
  from cM[G]
  obtain π where "π  M" "val(G, π) = c"
    using GenExt_def by auto
  let ="And(Member(0,1 #+ length(env)),φ)" and ?Pl1="[P,leq,one]"
  let ?new_form="sep_ren(length(env),forces())"
  let ="Exists(Exists(And(pair_fm(0,1,2),?new_form)))"
  note phi = φformula› ‹arity(φ)  1 #+ length(env) 
  then
  have "formula" by simp
  with env_ phi
  have "arity()  2#+length(env) " 
    using nat_simp_union leI by simp
  with envlist(_) phi
  have "arity(forces())  6 #+ length(env)"
    using  arity_forces_le by simp
  then
  have "arity(forces())  7 #+ length(env)"
    using nat_simp_union arity_forces leI by simp
  with ‹arity(forces()) 7 #+ _ env  _ φ  formula›
  have "arity(?new_form)  7 #+ length(env)" "?new_form  formula"
    using arity_rensep[OF definability[of ""]]  definability[of ""] type_rensep 
    by auto
  then
  have "pred(pred(arity(?new_form)))  5 #+ length(env)" "formula"
    unfolding pair_fm_def upair_fm_def 
    using nat_simp_union length_type[OF envlist(M[G])] 
        pred_mono[OF _ pred_mono[OF _ ‹arity(?new_form)  _]]
    by auto
  with ‹arity(?new_form)  _ ?new_form  formula›
  have "arity()  5 #+ length(env)"
    unfolding pair_fm_def upair_fm_def 
    using nat_simp_union arity_forces
    by auto
  from φformula›
  have "forces()  formula"
    using definability by simp
  from πM P_in_M 
  have "domain(π)M" "domain(π) × P  M"
    by (simp_all flip:setclass_iff)
  from env  _
  obtain nenv where "nenvlist(M)" "env = map(val(G),nenv)" "length(nenv) = length(env)"
    using map_val by auto
  from ‹arity(φ)  _ env_ φ_
  have "arity(φ)  2#+ length(env)" 
    using le_trans[OF ‹arity(φ)_] add_le_mono[of 1 2,OF _ le_refl] 
    by auto
  with nenv_ env_ πM φ_ ‹length(nenv) = length(env)
  have "arity()  length([θ] @ nenv @ [π])" for θ 
    using nat_union_abs2[OF _ _ ‹arity(φ)  2#+ _] nat_simp_union 
    by simp    
  note in_M = πM ‹domain(π) × P  M  P_in_M one_in_M leq_in_M
  {
    fix u
    assume "u  domain(π) × P" "u  M"
    with in_M ?new_form  formula› formula› nenv  _
    have Eq1: "(M, [u] @ ?Pl1 @ [π] @ nenv  )  
                        (θM. pP. u =θ,p  
                          M, [θ,p,u]@?Pl1@[π] @ nenv  ?new_form)"
      by (auto simp add: transitivity)
    have Eq3: "θM  pP 
       (M, [θ,p,u]@?Pl1@[π]@nenv  ?new_form) 
          (F. M_generic(F)  p  F  (M[F],  map(val(F), [θ] @ nenv@[π])   ))" 
      for θ p 
    proof -
      fix p θ 
      assume "θ  M" "pP"
      then 
      have "pM" using P_in_M by (simp add: transitivity)
      note in_M' = in_M θ  M pM u  domain(π) × P u  M nenv_
      then 
      have "[θ,u]  list(M)" by simp
      let ?env="[p]@?Pl1@[θ] @ nenv @ [π,u]"
      let ?new_env=" [θ,p,u,P,leq,one,π] @ nenv"
      let ="Exists(Exists(And(pair_fm(0,1,2),?new_form)))"
      have "[θ, p, u, π, leq, one, π]  list(M)" 
        using in_M' by simp
      have "  formula" "forces() formula"  
        using phi by simp_all
      from in_M' 
      have "?Pl1  list(M)" by simp
      from in_M' have "?env  list(M)" by simp
      have Eq1': "?new_env  list(M)" using in_M'  by simp 
      then 
      have "(M, [θ,p,u]@?Pl1@[π] @ nenv  ?new_form)  (M, ?new_env  ?new_form)"
        by simp
      from in_M' env  _ Eq1' ‹length(nenv) = length(env) 
        ‹arity(forces())  7 #+ length(env) ‹forces() formula›
        [θ, p, u, π, leq, one, π]  list(M) 
      have "...  M, ?env  forces()"
        using sepren_action[of "forces()"  "nenv",OF _ _ nenvlist(M)] 
        by simp
      also from in_M'
      have "...  M,  ([p,P, leq, one,θ]@nenv@ [π])@[u]  forces()" 
        using app_assoc by simp
      also 
      from in_M' env_ phi ‹length(nenv) = length(env)
        ‹arity(forces())  6 #+ length(env) ‹forces()formula›
      have "...  M,  [p,P, leq, one,θ]@ nenv @ [π]  forces()"        
        by (rule_tac arity_sats_iff,auto)
      also 
      from ‹arity(forces())  6 #+ length(env) ‹forces()formula› in_M' phi 
      have " ...  (F. M_generic(F)  p  F  
                           M[F],  map(val(F), [θ] @ nenv @ [π])   )"
        using  definition_of_forcing 
      proof (intro iffI)
        assume a1: "M,  [p,P, leq, one,θ] @ nenv @ [π]   forces()"
        note definition_of_forcing ‹arity(φ) 1#+_
        with nenv_ ‹arity()  length([θ] @ nenv @ [π]) env_
        have "p  P  formula  [θ,π]  list(M) 
                  M, [p,P, leq, one] @ [θ]@ nenv@[π]  forces()  
              G. M_generic(G)  p  G  M[G],  map(val(G), [θ] @ nenv @[π])   "
          by auto
        then
        show "F. M_generic(F)  p  F  
                  M[F],  map(val(F), [θ] @ nenv @ [π])   "
          using  formula› pP a1 θM πM by simp
      next
        assume "F. M_generic(F)  p  F  
                   M[F],  map(val(F), [θ] @ nenv @[π])   "
        with definition_of_forcing [THEN iffD2] ‹arity()  length([θ] @ nenv @ [π])
        show "M,  [p, P, leq, one,θ] @ nenv @ [π]   forces()"
          using  formula› pP in_M' 
          by auto
      qed
      finally 
      show "(M, [θ,p,u]@?Pl1@[π]@nenv  ?new_form)  (F. M_generic(F)  p  F  
                           M[F],  map(val(F), [θ] @ nenv @ [π])   )" 
        by simp
    qed
    with Eq1 
    have "(M, [u] @ ?Pl1 @ [π] @ nenv  )  
         (θM. pP. u =θ,p  
          (F. M_generic(F)  p  F  M[F],  map(val(F), [θ] @ nenv @ [π])   ))"
      by auto 
  }
  then 
  have Equivalence: "u domain(π) × P  u  M  
       (M, [u] @ ?Pl1 @ [π] @ nenv  )  
         (θM. pP. u =θ,p  
          (F. M_generic(F)  p  F  M[F],   map(val(F), [θ] @ nenv @[π])   ))" 
    for u 
    by simp
  moreover from env = _ πM nenvlist(M)
  have map_nenv:"map(val(G), nenv@[π]) = env @ [val(G,π)]"
    using map_app_distrib append1_eq_iff by auto
  ultimately
  have aux:"(θM. pP. u =θ,p  (pG  M[G], [val(G,θ)] @ env @ [val(G,π)]  ))" 
   (is "(θM. pP. _ ( _  _, ?vals(θ)  _))")
   if "u  domain(π) × P" "u  M"  "M, [u]@ ?Pl1 @[π] @ nenv  " for u
    using Equivalence[THEN iffD1, OF that] generic by force
  moreover 
  have "θM  val(G,θ)M[G]" for θ
    using GenExt_def by auto
  moreover
  have "θ M  [val(G, θ)] @ env @ [val(G, π)]  list(M[G])" for θ
  proof -
    from πM
    have "val(G,π) M[G]" using GenExtI by simp
    moreover
    assume "θ  M"
    moreover
    note env  list(M[G])
    ultimately
    show ?thesis 
      using GenExtI by simp
  qed
  ultimately 
  have "(θM. pP. u=θ,p  (pG  val(G,θ)nth(1 #+ length(env),[val(G, θ)] @ env @ [val(G, π)]) 
         M[G],  ?vals(θ)   φ))"
    if "u  domain(π) × P" "u  M"  "M, [u] @ ?Pl1 @[π] @ nenv  " for u
    using aux[OF that] by simp
  moreover from env  _ πM
  have nth:"nth(1 #+ length(env),[val(G, θ)] @ env @ [val(G, π)]) = val(G,π)" 
    if "θM" for θ
    using nth_concat[of "val(G,θ)" "val(G,π)" "M[G]"] using that GenExtI by simp
  ultimately
  have "(θM. pP. u=θ,p  (pG  val(G,θ)val(G,π)  M[G],  ?vals(θ)   φ))"
    if "u  domain(π) × P" "u  M"  "M, [u] @ ?Pl1 @[π] @ nenv  " for u
    using that πM env  _ by simp
  with ‹domain(π)×PM
  have "udomain(π)×P . (M, [u] @ ?Pl1 @[π] @ nenv  )  (θM. pP. u =θ,p 
        (p  G  val(G, θ)val(G, π)  M[G],  ?vals(θ)   φ))"
    by (simp add:transitivity)
  then 
  have "{udomain(π)×P . (M,[u] @ ?Pl1 @[π] @ nenv  ) } 
     {udomain(π)×P . θM. pP. u =θ,p  
       (p  G  val(G, θ)val(G, π)  (M[G], ?vals(θ)  φ))}"
    (is "?n?m") 
    by auto
  with val_mono 
  have first_incl: "val(G,?n)  val(G,?m)" 
    by simp
  note  ‹val(G,π) = c (* from the assumptions *)
  with formula›  ‹arity()  _ in_M nenv  _ env  _ ‹length(nenv) = _ 
  have "?nM" 
    using separation_ax leI separation_iff by auto 
  from generic 
  have "filter(G)" "GP" 
    unfolding M_generic_def filter_def by simp_all
  from ‹val(G,π) = c 
  have "val(G,?m) =
               {val(G,t) .. tdomain(π) , qP .  
                    (θM. pP. t,q = θ, p  
            (p  G  val(G, θ)  c  (M[G],  [val(G, θ)] @ env @ [c]   φ))  q  G)}"
    using val_of_name by auto
  also 
  have "... =  {val(G,t) .. tdomain(π) , qP. 
                   val(G, t)  c  (M[G],  [val(G, t)] @ env @ [c]   φ)  q  G}" 
  proof -

    have "tM 
      (qP. (θM. pP. t,q = θ, p  
              (p  G  val(G, θ)  c  (M[G],  [val(G, θ)] @ env @ [c]   φ))  q  G)) 
       
      (qP. val(G, t)  c  ( M[G], [val(G, t)]@env@[c] φ )  q  G)" for t
      by auto
    then show ?thesis using ‹domain(π)M by (auto simp add:transitivity)
  qed
  also 
  have "... =  {x .. xc , qP. x  c  (M[G],  [x] @ env @ [c]   φ)  q  G}"
  proof

    show "...  {x .. xc , qP. x  c  (M[G],  [x] @ env @ [c]   φ)  q  G}"
      by auto
  next 
    (* Now we show the other inclusion:
      {x .. x∈c , ∃q∈P. x ∈ c ∧ (M[G],  [x, w, c] ⊨  φ) ∧ q ∈ G}
      ⊆
      {val(G,t)..t∈domain(π),∃q∈P.val(G,t)∈c∧(M[G], [val(G,t),w] ⊨ φ)∧q∈G}
    *)
    {
      fix x
      assume "x{x .. xc , qP. x  c  (M[G],  [x] @ env @ [c]   φ)  q  G}"
      then 
      have "qP. x  c  (M[G],  [x] @ env @ [c]   φ)  q  G"
        by simp
      with ‹val(G,π) = c  
      have "qP. tdomain(π). val(G,t) =x  (M[G],  [val(G,t)] @ env @ [c]   φ)  q  G" 
        using Sep_and_Replace elem_of_val by auto
    }
    then 
    show " {x .. xc , qP. x  c  (M[G],  [x] @ env @ [c]   φ)  q  G}  ..."
      using SepReplace_iff by force
  qed
  also 
  have " ... = {xc. (M[G], [x] @ env @ [c]  φ)}"
    using GP G_nonempty by force
  finally 
  have val_m: "val(G,?m) = {xc. (M[G], [x] @ env @ [c]  φ)}" by simp
  have "val(G,?m)  val(G,?n)" 
  proof
    fix x
    assume "x  val(G,?m)"
    with val_m 
    have Eq4: "x  {xc. (M[G], [x] @ env @ [c]  φ)}" by simp
    with ‹val(G,π) = c
    have "x  val(G,π)" by simp
    then 
    have "θ. qG. θ,qπ  val(G,θ) =x" 
      using elem_of_val_pair by auto
    then obtain θ q where
      "θ,qπ" "qG" "val(G,θ)=x" by auto
    from θ,qπ
    have "θM"
      using domain_trans[OF trans_M π_] by auto
    with πM nenv  _ env = _
    have "[val(G,θ), val(G,π)] @ env list(M[G])" 
      using GenExt_def by auto
    with  Eq4 ‹val(G,θ)=x ‹val(G,π) = c x  val(G,π) nth θM
    have Eq5: "M[G],  [val(G,θ)] @ env @[val(G,π)]  And(Member(0,1 #+ length(env)),φ)" 
      by auto
        (* Recall ?χ = And(Member(0,1 #+ length(env)),φ) *)
    with θM πM  Eq5 ‹M_generic(G) φformula› nenv  _ env = _ map_nenv 
      ‹arity()  length([θ] @ nenv @ [π])
    have "(rG. M,  [r,P,leq,one,θ] @ nenv @[π]  forces())"
      using truth_lemma  
      by auto
    then obtain r where      (* I can't "obtain" this directly *)
      "rG" "M,  [r,P,leq,one,θ] @ nenv @ [π]  forces()" by auto
    with ‹filter(G) and qG obtain p where
      "pG" "pq" "pr" 
      unfolding filter_def compat_in_def by force
    with rG  qG GP 
    have "pP" "rP" "qP" "pM"
      using  P_in_M  by (auto simp add:transitivity)
    with φformula› θM πM  pr nenv  _ ‹arity()  length([θ] @ nenv @ [π])
      M, [r,P,leq,one,θ] @ nenv @ [π]  forces() env_
    have "M,  [p,P,leq,one,θ] @ nenv @ [π]  forces()"
      using strengthening_lemma 
      by simp
    with pP φformula› θM πM nenv  _ ‹arity()  length([θ] @ nenv @ [π])
    have "F. M_generic(F)  p  F  
                 M[F],   map(val(F), [θ] @ nenv @[π])   "
      using definition_of_forcing
      by simp
    with pP θM  
    have Eq6: "θ'M. p'P.  θ,p = <θ',p'>  (F. M_generic(F)  p'  F  
                 M[F],   map(val(F), [θ'] @ nenv @ [π])   )" by auto
    from πM θ,qπ 
    have "θ,q  M" by (simp add:transitivity)
    from θ,qπ θM pP  pM 
    have "θ,pM" "θ,pdomain(π)×P" 
      using tuples_in_M by auto
    with θM Eq6 pP
    have "M, [θ,p] @ ?Pl1 @ [π] @ nenv  "
      using Equivalence  by auto
    with θ,pdomain(π)×P 
    have "θ,p?n" by simp
    with pG pP 
    have "val(G,θ)val(G,?n)" 
      using  val_of_elem[of θ p] by simp
    with ‹val(G,θ)=x 
    show "xval(G,?n)" by simp
  qed (* proof of "val(G,?m) ⊆ val(G,?n)" *)
  with val_m first_incl 
  have "val(G,?n) = {xc. (M[G], [x] @ env @ [c]  φ)}" by auto
  also 
  have " ... = {xc. (M[G], [x] @ env  φ)}" 
  proof -
    {
      fix x
      assume "xc"
      moreover from assms 
      have "cM[G]"
        unfolding GenExt_def by auto
      moreover from this and xc 
      have "xM[G]"
        using transitivity_MG
        by simp
      ultimately 
      have "(M[G],  ([x] @ env) @[c]   φ)  (M[G],  [x] @ env   φ)" 
        using phi env  _ by (rule_tac arity_sats_iff, simp_all)   (* Enhance this *)
    }
    then show ?thesis by auto
  qed      
  finally 
  show "{xc. (M[G], [x] @ env  φ)} M[G]" 
    using ?nM GenExt_def by force
qed

theorem separation_in_MG:
  assumes 
    "φformula" and "arity(φ)  1 #+ length(env)" and "envlist(M[G])"
  shows  
    "separation(##M[G],λx. (M[G], [x] @ env  φ))"
proof -
  { 
    fix c
    assume "cM[G]" 
    moreover from env  _
    obtain nenv where  "nenvlist(M)" 
      "env = map(val(G),nenv)" "length(env) = length(nenv)"
      using GenExt_def map_val[of env] by auto
    moreover note φ  _ ‹arity(φ)  _ env  _
    ultimately
    have Eq1: "{xc. (M[G], [x] @ env  φ)}  M[G]"
      using Collect_sats_in_MG  by auto
  }
  then 
  show ?thesis 
    using separation_iff rev_bexI unfolding is_Collect_def by force
qed

end (* context: G_generic *)

end

Theory Pairing_Axiom

section‹The Axiom of Pairing in $M[G]$›
theory Pairing_Axiom imports Names begin

context forcing_data
begin

lemma val_Upair :
  "one  G  val(G,{τ,one,ρ,one}) = {val(G,τ),val(G,ρ)}"
  by (insert one_in_P, rule trans, subst def_val,auto simp add: Sep_and_Replace)

lemma pairing_in_MG : 
  assumes "M_generic(G)"
  shows "upair_ax(##M[G])"
proof - 
  {
    fix x y
    have "oneG" using assms one_in_G by simp
    from assms 
    have "GP" unfolding M_generic_def and filter_def by simp
    with oneG
    have "oneP" using subsetD by simp
    then 
    have "oneM" using transitivity[OF _ P_in_M] by simp
    assume "x  M[G]" "y  M[G]"
    then 
    obtain τ ρ where
      0 : "val(G,τ) = x" "val(G,ρ) = y" "ρ  M"  "τ  M"
      using GenExtD by blast
    with oneM 
    have "τ,one  M" "ρ,oneM" using pair_in_M_iff by auto
    then 
    have 1: "{τ,one,ρ,one}  M" (is "  _") using upair_in_M_iff by simp
    then 
    have "val(G,)  M[G]" using GenExtI by simp
    with 1 
    have "{val(G,τ),val(G,ρ)}  M[G]" using val_Upair assms one_in_G by simp
    with 0 
    have "{x,y}  M[G]" by simp
  }
  then show ?thesis unfolding upair_ax_def upair_def by auto
qed

end  (* context forcing_data *)
end

Theory Union_Axiom

section‹The Axiom of Unions in $M[G]$›
theory Union_Axiom
  imports Names
begin

context forcing_data
begin


definition Union_name_body :: "[i,i,i,i]  o" where
  "Union_name_body(P',leq',τ,θp)  ( σ[##M].
            q[##M]. (q P'  (σ,q  τ 
            ( r[##M].rP'  (fst(θp),r  σ  snd(θp),r  leq'  snd(θp),q  leq')))))"

definition Union_name_fm :: "i" where
  "Union_name_fm 
    Exists(
    Exists(And(pair_fm(1,0,2),
    Exists (
    Exists (And(Member(0,7),
      Exists (And(And(pair_fm(2,1,0),Member(0,6)),
        Exists (And(Member(0,9),
         Exists (And(And(pair_fm(6,1,0),Member(0,4)),
          Exists (And(And(pair_fm(6,2,0),Member(0,10)),
          Exists (And(pair_fm(7,5,0),Member(0,11)))))))))))))))))"

lemma Union_name_fm_type [TC]:
  "Union_name_fm formula"
  unfolding Union_name_fm_def by simp


lemma arity_Union_name_fm :
  "arity(Union_name_fm) = 4"
  unfolding Union_name_fm_def upair_fm_def pair_fm_def
  by(auto simp add: nat_simp_union)

lemma sats_Union_name_fm :
  " a  M; b  M ; P'  M ; p  M ; θ  M ; τ  M ; leq'  M  
     sats(M,Union_name_fm,[θ,p,τ,leq',P']@[a,b]) 
     Union_name_body(P',leq',τ,θ,p)"
  unfolding Union_name_fm_def Union_name_body_def tuples_in_M
  by (subgoal_tac "θ,p  M", auto simp add : tuples_in_M)


lemma domD :
  assumes "τ  M" "σ  domain(τ)"
  shows "σ  M"
  using assms Transset_M trans_M
  by (simp flip: setclass_iff)


definition Union_name :: "i  i" where
  "Union_name(τ) 
    {u  domain((domain(τ))) × P . Union_name_body(P,leq,τ,u)}"

lemma Union_name_M : assumes "τ  M"
  shows "{u  domain((domain(τ))) × P . Union_name_body(P,leq,τ,u)}  M"
  unfolding Union_name_def
proof -
  let ?P="λ x . sats(M,Union_name_fm,[x,τ,leq]@[P,τ,leq])"
  let ?Q="λ x . Union_name_body(P,leq,τ,x)"
  from τM
  have "domain((domain(τ)))M" (is "?d  _") using domain_closed Union_closed by simp
  then
  have "?d × P  M" using cartprod_closed P_in_M by simp
  have "arity(Union_name_fm)6" using arity_Union_name_fm by simp
  from assms P_in_M leq_in_M  arity_Union_name_fm
  have "[τ,leq]  list(M)" "[P,τ,leq]  list(M)" by auto
  with assms assms P_in_M leq_in_M  ‹arity(Union_name_fm)6
  have "separation(##M,?P)"
    using separation_ax by simp
  with ?d × P  M
  have A:"{ u  ?d × P . ?P(u) }  M"
    using  separation_iff by force
  have "?P(x) ?Q(x)" if "x ?d×P" for x
  proof -
    from x ?d×P
    have "x = fst(x),snd(x)" using Pair_fst_snd_eq by simp
    with x?d×P ?dM
    have "fst(x)  M" "snd(x)  M"
      using mtrans fst_type snd_type P_in_M unfolding M_trans_def by auto
    then
    have "?P(fst(x),snd(x))   ?Q(fst(x),snd(x))"
      using P_in_M sats_Union_name_fm P_in_M τM leq_in_M by simp
    with x = fst(x),snd(x)
    show "?P(x)  ?Q(x)" using that by simp
  qed
  then show ?thesis using Collect_cong A by simp
qed



lemma Union_MG_Eq :
  assumes "a  M[G]" and "a = val(G,τ)" and "filter(G)" and "τ  M"
  shows " a = val(G,Union_name(τ))"
proof -
  {
    fix x
    assume "x   (val(G,τ))"
    then obtain i where "i  val(G,τ)" "x  i" by blast
    with τ  M obtain σ q where
      "q  G" "σ,q  τ" "val(G,σ) = i" "σ  M"
      using elem_of_val_pair domD by blast
    with x  i obtain θ r where
      "r  G" "θ,r  σ" "val(G,θ) = x" "θ  M"
      using elem_of_val_pair domD by blast
    with σ,qτ have "θ  domain((domain(τ)))" by auto
    with ‹filter(G) qG rG obtain p where
      A: "p  G" "p,r  leq" "p,q  leq" "p  P" "r  P" "q  P"
      using low_bound_filter filterD  by blast
    then have "p  M" "qM" "rM"
      using mtrans P_in_M unfolding M_trans_def by auto
    with A θ,r  σ σ,q  τ θ  M θ  domain((domain(τ)))  σM have
      "θ,p  Union_name(τ)" unfolding Union_name_def Union_name_body_def
      by auto
    with pP pG have "val(G,θ)  val(G,Union_name(τ))"
      using val_of_elem by simp
    with ‹val(G,θ)=x have "x  val(G,Union_name(τ))" by simp
  }
  with a=val(G,τ) have 1: "x   a  x  val(G,Union_name(τ))" for x by simp
  {
    fix x
    assume "x  (val(G,Union_name(τ)))"
    then obtain θ p where
      "p  G" "θ,p  Union_name(τ)" "val(G,θ) = x"
      using elem_of_val_pair by blast
    with ‹filter(G) have "pP" using filterD by simp
    from θ,p  Union_name(τ) obtain σ q r where
      "σ  domain(τ)"  "σ,q  τ " "θ,r  σ" "rP" "qP" "p,r  leq" "p,q  leq"
      unfolding Union_name_def Union_name_body_def by force
    with pG ‹filter(G) have "r  G" "q  G"
      using filter_leqD by auto
    with θ,r  σ σ,qτ qP rP have
      "val(G,σ)  val(G,τ)" "val(G,θ)  val(G,σ)"
      using val_of_elem by simp+
    then have "val(G,θ)   val(G,τ)" by blast
    with ‹val(G,θ)=x a=val(G,τ) have
      "x   a" by simp
  }
  with a=val(G,τ)
  have "x  val(G,Union_name(τ))  x   a" for x by blast
  then
  show ?thesis using 1 by blast
qed

lemma union_in_MG : assumes "filter(G)"
  shows "Union_ax(##M[G])"
proof -
  { fix a
    assume "a  M[G]"
    then
    interpret mgtrans : M_trans "##M[G]"
      using transitivity_MG by (unfold_locales; auto)
    from a_ obtain τ where "τ  M" "a=val(G,τ)" using GenExtD by blast
    then
    have "Union_name(τ)  M" (is "  _") using Union_name_M unfolding Union_name_def by simp
    then
    have "val(G,)  M[G]" (is "?U  _") using GenExtI by simp
    with a_
    have "(##M[G])(a)" "(##M[G])(?U)" by auto
    with τ  M ‹filter(G) ?U  M[G] a=val(G,τ)
    have "big_union(##M[G],a,?U)"
      using Union_MG_Eq Union_abs  by simp
    with ?U  M[G]
    have "z[##M[G]]. big_union(##M[G],a,z)" by force
  }
  then
  have "Union_ax(##M[G])" unfolding Union_ax_def by force
  then
  show ?thesis by simp
qed

theorem Union_MG : "M_generic(G)  Union_ax(##M[G])"
  by (simp add:M_generic_def union_in_MG)

end (* forcing_data *)
end

Theory Powerset_Axiom

section‹The Powerset Axiom in $M[G]$›
theory Powerset_Axiom
  imports Renaming_Auto Separation_Axiom Pairing_Axiom Union_Axiom
begin

simple_rename "perm_pow" src "[ss,p,l,o,fs,χ]" tgt "[fs,ss,sp,p,l,o,χ]"

lemma Collect_inter_Transset:
  assumes
    "Transset(M)" "b  M"
  shows
    "{xb . P(x)} = {xb . P(x)}  M"
  using assms unfolding Transset_def
  by (auto)

context G_generic  begin

lemma name_components_in_M:
  assumes "<σ,p>θ" "θ  M"
  shows   "σM" "pM"
proof -
  from assms obtain a where
    "σ  a" "p  a" "a<σ,p>"
    unfolding Pair_def by auto
  moreover from assms
  have "<σ,p>M"
    using transitivity by simp
  moreover from calculation
  have "aM"
    using transitivity by simp
  ultimately
  show "σM" "pM"
    using transitivity by simp_all
qed

lemma sats_fst_snd_in_M:
  assumes
    "AM" "BM" "φ  formula" "pM" "lM" "oM" "χM"
    "arity(φ)  6"
  shows
    "{sq A×B . sats(M,φ,[snd(sq),p,l,o,fst(sq),χ])}  M"
    (is "  M")
proof -
  have "6nat" "7nat" by simp_all
  let ?φ' = "ren(φ)`6`7`perm_pow_fn"
  from AM BM have
    "A×B  M"
    using cartprod_closed by simp
  from ‹arity(φ)  6 φ formula› 6_ 7_
  have "?φ'  formula" "arity(?φ')7"
    unfolding perm_pow_fn_def
    using  perm_pow_thm  arity_ren ren_tc Nil_type
    by auto
  with ?φ'  formula›
  have 1: "arity(Exists(Exists(And(pair_fm(0,1,2),?φ'))))5"     (is "arity()5")
    unfolding pair_fm_def upair_fm_def
    using nat_simp_union pred_le arity_type by auto
  {
    fix sp
    note A×B  M
    moreover
    assume "sp  A×B"
    moreover from calculation
    have "fst(sp)  A" "snd(sp)  B"
      using fst_type snd_type by simp_all
    ultimately
    have "sp  M" "fst(sp)  M" "snd(sp)  M"
      using  AM BM transitivity
      by simp_all
    note inM = AM BM pM lM oM χM
      spM ‹fst(sp)M ‹snd(sp)M
    with 1 sp  M ?φ'  formula›
    have "M, [sp,p,l,o,χ]@[p]    M,[sp,p,l,o,χ]  " (is "M,?env0@ __  _")
      using arity_sats_iff[of  "[p]" M ?env0] by auto
    also from inM sp  A×B
    have "...  sats(M,?φ',[fst(sp),snd(sp),sp,p,l,o,χ])"
      by auto
    also from inM φ  formula› ‹arity(φ)  6
    have "...  sats(M,φ,[snd(sp),p,l,o,fst(sp),χ])"
      (is "sats(_,_,?env1)  sats(_,_,?env2)")
      using sats_iff_sats_ren[of φ 6 7 ?env2 M ?env1 perm_pow_fn] perm_pow_thm
      unfolding perm_pow_fn_def by simp
    finally
    have "sats(M,,[sp,p,l,o,χ,p])  sats(M,φ,[snd(sp),p,l,o,fst(sp),χ])"
      by simp
  }
  then have
    " = {spA×B . sats(M,,[sp,p,l,o,χ,p])}"
    by auto
  also from assms A×BM have
    " ...  M"
  proof -
    from 1
    have "arity()  6"
      using leI by simp
    moreover from ?φ'  formula›
    have "  formula"
      by simp
    moreover note assms A×BM
    ultimately 
    show "{x  A×B . sats(M, , [x, p, l, o, χ, p])}  M"
      using separation_ax separation_iff
      by simp
  qed
  finally show ?thesis .
qed

lemma Pow_inter_MG:
  assumes
    "aM[G]"
  shows
    "Pow(a)  M[G]  M[G]"
proof -
  from assms obtain τ where
    "τ  M" "val(G, τ) = a"
    using GenExtD by auto
  let ?Q="Pow(domain(τ)×P)  M"
  from τM 
  have "domain(τ)×P  M" "domain(τ)  M"
    using domain_closed cartprod_closed P_in_M
    by simp_all
  then 
  have "?Q  M"
  proof -
    from power_ax ‹domain(τ)×P  M obtain Q where
      "powerset(##M,domain(τ)×P,Q)" "Q  M"
      unfolding power_ax_def by auto
    moreover from calculation 
    have "zQ  zM" for z
      using transitivity by blast
    ultimately
    have "Q = {aPow(domain(τ)×P) . aM}"
      using ‹domain(τ)×P  M powerset_abs[of "domain(τ)×P" Q]
      by (simp flip: setclass_iff)
    also 
    have " ... = ?Q"
      by auto
    finally 
    show ?thesis using QM by simp
  qed
  let
    ="?Q×{one}"
  let
    ?b="val(G,)"
  from ?QM 
  have "M"
    using one_in_P P_in_M transitivity
    by (simp flip: setclass_iff)
  from M 
  have "?b  M[G]"
    using GenExtI by simp
  have "Pow(a)  M[G]  ?b"
  proof
    fix c
    assume "c  Pow(a)  M[G]"
    then obtain χ where
      "cM[G]" "χ  M" "val(G,χ) = c"
      using GenExtD by auto
    let ="{sp domain(τ)×P . snd(sp)  (Member(0,1)) [fst(sp),χ] }"
    have "arity(forces(Member(0,1))) = 6"
      using arity_forces_at by auto
    with ‹domain(τ)  M χ  M 
    have "  M"
      using P_in_M one_in_M leq_in_M sats_fst_snd_in_M
      by simp
    then 
    have "  ?Q"
      by auto
    then 
    have "val(G,)  ?b"
      using one_in_G one_in_P generic val_of_elem [of  one  G]
      by auto
    have "val(G,) = c"
    proof(intro equalityI subsetI)
      fix x
      assume "x  val(G,)"
      then obtain σ p where
        1: "<σ,p>" "pG" "val(G,σ) =  x"
        using elem_of_val_pair
        by blast
      moreover from <σ,p>   M
      have "σM"
        using name_components_in_M[of _ _ ] by auto
      moreover from 1 
      have "(p  (Member(0,1)) [σ,χ])" "pP"
        by simp_all
      moreover 
      note ‹val(G,χ) = c
      ultimately 
      have "sats(M[G],Member(0,1),[x,c])"
        using χ  M generic definition_of_forcing nat_simp_union
        by auto
      moreover 
      have "xM[G]"
        using ‹val(G,σ) =  x σM  χM GenExtI by blast
      ultimately 
      show "xc"
        using cM[G] by simp
    next
      fix x
      assume "x  c"
      with c  Pow(a)  M[G] 
      have "x  a" "cM[G]" "xM[G]"
        using transitivity_MG
        by auto
      with ‹val(G, τ) = a 
      obtain σ where
        "σdomain(τ)" "val(G,σ) =  x"
        using elem_of_val
        by blast
      moreover note xc ‹val(G,χ) = c
      moreover from calculation 
      have "val(G,σ)  val(G,χ)"
        by simp
      moreover note cM[G] xM[G]
      moreover from calculation 
      have "sats(M[G],Member(0,1),[x,c])"
        by simp
      moreover 
      have "Member(0,1)formula" by simp
      moreover 
      have "σM"
      proof -
        from σdomain(τ) 
        obtain p where "<σ,p>  τ"
          by auto
        with τM 
        show ?thesis
          using name_components_in_M by blast
      qed
      moreover note χ  M
      ultimately 
      obtain p where "pG" "(p  Member(0,1) [σ,χ])"
        using generic truth_lemma[of "Member(0,1)" "G" "[σ,χ]" ] nat_simp_union
        by auto
      moreover from pG 
      have "pP"
        using generic unfolding M_generic_def filter_def by blast
      ultimately
      have "<σ,p>"
        using σdomain(τ) by simp
      with ‹val(G,σ) =  x pG 
      show "xval(G,)"
        using val_of_elem [of _ _ ""] by auto
    qed
    with ‹val(G,)  ?b 
    show "c?b" by simp
  qed
  then 
  have "Pow(a)  M[G] = {x?b . xa & xM[G]}"
    by auto
  also from aM[G] 
  have " ... = {x?b . sats(M[G],subset_fm(0,1),[x,a]) & xM[G]}"
    using Transset_MG by force
  also 
  have " ... = {x?b . sats(M[G],subset_fm(0,1),[x,a])}  M[G]"
    by auto
  also from ?bM[G] 
  have " ... = {x?b . sats(M[G],subset_fm(0,1),[x,a])}"
    using Collect_inter_Transset Transset_MG
    by simp
  also from ?bM[G] aM[G]
  have " ...  M[G]"
    using Collect_sats_in_MG GenExtI nat_simp_union by simp
  finally show ?thesis .
qed
end (* context: G_generic *)


context G_generic begin

interpretation mgtriv: M_trivial "##M[G]"
  using generic Union_MG pairing_in_MG zero_in_MG transitivity_MG
  unfolding M_trivial_def M_trans_def M_trivial_axioms_def by (simp; blast)


theorem power_in_MG : "power_ax(##(M[G]))"
  unfolding power_ax_def
proof (intro rallI, simp only:setclass_iff rex_setclass_is_bex)
  (* After simplification, we have to show that for every
     a∈M[G] there exists some x∈M[G] with powerset(##M[G],a,x)
  *)
  fix a
  assume "a  M[G]"
  then
  have "(##M[G])(a)" by simp
  have "{xPow(a) . x  M[G]} = Pow(a)  M[G]"
    by auto
  also from aM[G] 
  have " ...  M[G]"
    using Pow_inter_MG by simp
  finally 
  have "{xPow(a) . x  M[G]}  M[G]" .
  moreover from aM[G] {xPow(a) . x  M[G]}  _ 
  have "powerset(##M[G], a, {xPow(a) . x  M[G]})"
    using mgtriv.powerset_abs[OF (##M[G])(a)]
    by simp
  ultimately 
  show "xM[G] . powerset(##M[G], a, x)"
    by auto
qed
end (* context: G_generic *)
end

Theory Extensionality_Axiom

section‹The Axiom of Extensionality in $M[G]$›
theory Extensionality_Axiom
imports
  Names
begin

context forcing_data
begin
  
lemma extensionality_in_MG : "extensionality(##(M[G]))"
proof -
  {
    fix x y z
    assume 
      asms: "xM[G]" "yM[G]" "(wM[G] . w  x  w  y)"
    from xM[G] have
      "zx  zM[G]  zx"
      using transitivity_MG by auto
    also have
      "...  zy"
      using asms transitivity_MG by auto
    finally have
      "zx  zy" .
  }
  then have
    "xM[G] . yM[G] . (zM[G] . z  x  z  y)  x = y"
    by blast
  then show ?thesis unfolding extensionality_def by simp
qed
 
end  (* context forcing_data *)
end

Theory Foundation_Axiom

section‹The Axiom of Foundation in $M[G]$›
theory Foundation_Axiom
imports
  Names
begin

context forcing_data
begin
  
(* Slick proof essentially by Paulson (adapted from L) *)  
lemma foundation_in_MG : "foundation_ax(##(M[G]))"
  unfolding foundation_ax_def
  by (rule rallI, cut_tac A=x in foundation, auto intro: transitivity_MG)

(* Same theorem as above, declarative proof, 
   without using transitivity *)
lemma "foundation_ax(##(M[G]))"
proof -
  {   
    fix x 
    assume "xM[G]" "yM[G] . yx"
    then 
    have "yM[G] . yxM[G]" by simp
    then 
    obtain y where "yxM[G]" "zy. z  xM[G]" 
      using foundation[of "xM[G]"]  by blast
    then 
    have "yM[G] . y  x  (zM[G] . z  x  z  y)"by auto
  }
  then show ?thesis
    unfolding foundation_ax_def by auto
qed
    
end  (* context forcing_data *)
end

Theory Least

section‹The binder termLeast
theory Least
  imports
    Names

begin

text‹We have some basic results on the least ordinal satisfying
a predicate.›

lemma Least_Ord: "(μ α. R(α)) = (μ α. Ord(α)  R(α))"
  unfolding Least_def by (simp add:lt_Ord)

lemma Ord_Least_cong: 
  assumes "y. Ord(y)  R(y)  Q(y)"
  shows "(μ α. R(α)) = (μ α. Q(α))"
proof -
  from assms
  have "(μ α. Ord(α)  R(α)) = (μ α. Ord(α)  Q(α))"
    by simp 
  then
  show ?thesis using Least_Ord by simp
qed

definition
  least :: "[io,io,i]  o" where
  "least(M,Q,i)  ordinal(M,i)  (
         (empty(M,i)  (b[M]. ordinal(M,b)  ¬Q(b)))
        (Q(i)  (b[M]. ordinal(M,b)  bi ¬Q(b))))"

definition
  least_fm :: "[i,i]  i" where
  "least_fm(q,i)  And(ordinal_fm(i),
   Or(And(empty_fm(i),Forall(Implies(ordinal_fm(0),Neg(q)))), 
      And(Exists(And(q,Equal(0,succ(i)))),
          Forall(Implies(And(ordinal_fm(0),Member(0,succ(i))),Neg(q))))))"

lemma least_fm_type[TC] :"i  nat  qformula  least_fm(q,i)  formula"
  unfolding least_fm_def
  by simp

(* Refactorize Formula and Relative to include the following three lemmas *)
lemmas basic_fm_simps = sats_subset_fm' sats_transset_fm' sats_ordinal_fm'

lemma sats_least_fm :
  assumes p_iff_sats: 
    "a. a  A  P(a)  sats(A, p, Cons(a, env))"
  shows
    "y  nat; env  list(A) ; 0A
     sats(A, least_fm(p,y), env) 
        least(##A, P, nth(y,env))"
  using nth_closed p_iff_sats unfolding least_def least_fm_def
  by (simp add:basic_fm_simps)

lemma least_iff_sats:
  assumes is_Q_iff_sats: 
      "a. a  A  is_Q(a)  sats(A, q, Cons(a,env))"
  shows 
  "nth(j,env) = y; j  nat; env  list(A); 0A
    least(##A, is_Q, y)  sats(A, least_fm(q,j), env)"
  using sats_least_fm [OF is_Q_iff_sats, of j , symmetric]
  by simp

lemma least_conj: "aM  least(##M, λx. xM  Q(x),a)  least(##M,Q,a)"
  unfolding least_def by simp

(* Better to have this in M_basic or similar *)
lemma (in M_ctm) unique_least: "aM  bM  least(##M,Q,a)  least(##M,Q,b)  a=b"
  unfolding least_def
  by (auto, erule_tac i=a and j=b in Ord_linear_lt; (drule ltD | simp); auto intro:Ord_in_Ord)

context M_trivial
begin

subsection‹Absoluteness and closure under term‹Least›

lemma least_abs:
  assumes "x. Q(x)  M(x)" "M(a)" 
  shows "least(M,Q,a)  a = (μ x. Q(x))"
  unfolding least_def
proof (cases "b[M]. Ord(b)  ¬ Q(b)"; intro iffI; simp add:assms)
  case True
  with x. Q(x)  M(x)
  have "¬ (i. Ord(i)  Q(i)) " by blast
  then
  show "0 =(μ x. Q(x))" using Least_0 by simp
  then
  show "ordinal(M, μ x. Q(x))  (empty(M, Least(Q))  Q(Least(Q)))"
    by simp 
next
  assume "b[M]. Ord(b)  Q(b)"
  then 
  obtain i where "M(i)" "Ord(i)" "Q(i)" by blast
  assume "a = (μ x. Q(x))"
  moreover
  note M(a)
  moreover from  Q(i) ‹Ord(i)
  have "Q(μ x. Q(x))" (is ?G)
    by (blast intro:LeastI)
  moreover
  have "(b[M]. Ord(b)  b  (μ x. Q(x))  ¬ Q(b))" (is "?H")
    using less_LeastE[of Q _ False]
    by (auto, drule_tac ltI, simp, blast)
  ultimately
  show "ordinal(M, μ x. Q(x))  (empty(M, μ x. Q(x))  (b[M]. Ord(b)  ¬ Q(b))  ?G  ?H)"
    by simp
next
  assume 1:"b[M]. Ord(b)  Q(b)"
  then 
  obtain i where "M(i)" "Ord(i)" "Q(i)" by blast
  assume "Ord(a)  (a = 0  (b[M]. Ord(b)  ¬ Q(b))  Q(a)  (b[M]. Ord(b)  b  a  ¬ Q(b)))"
  with 1
  have "Ord(a)" "Q(a)" "b[M]. Ord(b)  b  a  ¬ Q(b)"
    by blast+
  moreover from this and x. Q(x)  M(x)
  have "Ord(b)  b  a  ¬ Q(b)" for b
    by blast
  moreover from this and ‹Ord(a)
  have "b < a  ¬ Q(b)" for b
    unfolding lt_def using Ord_in_Ord by blast
  ultimately
  show "a = (μ x. Q(x))"
    using Least_equality by simp
qed

lemma Least_closed:
  assumes "x. Q(x)  M(x)"
  shows "M(μ x. Q(x))"
  using assms LeastI[of Q] Least_0 by (cases "(i. Ord(i)  Q(i))", auto)

end (* M_trivial *)

end

Theory Replacement_Axiom

section‹The Axiom of Replacement in $M[G]$›
theory Replacement_Axiom
  imports
    Least Relative_Univ Separation_Axiom Renaming_Auto
begin

rename "renrep1" src "[p,P,leq,o,ρ,τ]" tgt "[V,τ,ρ,p,α,P,leq,o]"

definition renrep_fn :: "i  i" where
  "renrep_fn(env)  sum(renrep1_fn,id(length(env)),6,8,length(env))"

definition
  renrep :: "[i,i]  i" where
  "renrep(φ,env) = ren(φ)`(6#+length(env))`(8#+length(env))`renrep_fn(env)"

lemma renrep_type [TC]:
  assumes "φformula" "env  list(M)"
  shows "renrep(φ,env)  formula"
  unfolding renrep_def renrep_fn_def renrep1_fn_def
  using assms renrep1_thm(1) ren_tc
  by simp

lemma arity_renrep:
  assumes  "φformula" "arity(φ) 6#+length(env)" "env  list(M)"
  shows "arity(renrep(φ,env))  8#+length(env)"
  unfolding  renrep_def renrep_fn_def renrep1_fn_def
  using assms renrep1_thm(1) arity_ren
  by simp

lemma renrep_sats :
  assumes  "arity(φ)  6 #+ length(env)"
          "[P,leq,o,p,ρ,τ] @ env  list(M)"
    "V  M" "α  M"
    "φformula"
  shows "sats(M, φ, [p,P,leq,o,ρ,τ] @ env)  sats(M, renrep(φ,env), [V,τ,ρ,p,α,P,leq,o] @ env)"
  unfolding  renrep_def renrep_fn_def renrep1_fn_def
  by (rule sats_iff_sats_ren,insert assms, auto simp add:renrep1_thm(1)[of _ M,simplified]
        renrep1_thm(2)[simplified,where p=p and α=α])

rename "renpbdy1" src "[ρ,p,α,P,leq,o]" tgt "[ρ,p,x,α,P,leq,o]"

definition renpbdy_fn :: "i  i" where
  "renpbdy_fn(env)  sum(renpbdy1_fn,id(length(env)),6,7,length(env))"

definition
  renpbdy :: "[i,i]  i" where
  "renpbdy(φ,env) = ren(φ)`(6#+length(env))`(7#+length(env))`renpbdy_fn(env)"


lemma
  renpbdy_type [TC]: "φformula  envlist(M)  renpbdy(φ,env)  formula"
  unfolding renpbdy_def renpbdy_fn_def renpbdy1_fn_def
  using  renpbdy1_thm(1) ren_tc
  by simp

lemma  arity_renpbdy: "φformula  arity(φ)  6 #+ length(env)  envlist(M)  arity(renpbdy(φ,env))  7 #+ length(env)"
  unfolding renpbdy_def renpbdy_fn_def renpbdy1_fn_def
  using  renpbdy1_thm(1) arity_ren
  by simp

lemma
  sats_renpbdy: "arity(φ)  6 #+ length(nenv)  [ρ,p,x,α,P,leq,o,π] @ nenv  list(M)  φformula 
       sats(M, φ, [ρ,p,α,P,leq,o] @ nenv)  sats(M, renpbdy(φ,nenv), [ρ,p,x,α,P,leq,o] @ nenv)"
  unfolding renpbdy_def renpbdy_fn_def renpbdy1_fn_def
  by (rule sats_iff_sats_ren,auto simp add: renpbdy1_thm(1)[of _ M,simplified]
                                            renpbdy1_thm(2)[simplified,where α=α and x=x])


rename "renbody1" src "[x,α,P,leq,o]" tgt "[α,x,m,P,leq,o]"

definition renbody_fn :: "i  i" where
  "renbody_fn(env)  sum(renbody1_fn,id(length(env)),5,6,length(env))"

definition
  renbody :: "[i,i]  i" where
  "renbody(φ,env) = ren(φ)`(5#+length(env))`(6#+length(env))`renbody_fn(env)"

lemma
  renbody_type [TC]: "φformula  envlist(M)  renbody(φ,env)  formula"
  unfolding renbody_def renbody_fn_def renbody1_fn_def
  using  renbody1_thm(1) ren_tc
  by simp

lemma  arity_renbody: "φformula  arity(φ)  5 #+ length(env)  envlist(M) 
  arity(renbody(φ,env))  6 #+ length(env)"
  unfolding renbody_def renbody_fn_def renbody1_fn_def
  using  renbody1_thm(1) arity_ren
  by simp

lemma
  sats_renbody: "arity(φ)  5 #+ length(nenv)  [α,x,m,P,leq,o] @ nenv  list(M)  φformula 
       sats(M, φ, [x,α,P,leq,o] @ nenv)  sats(M, renbody(φ,nenv), [α,x,m,P,leq,o] @ nenv)"
  unfolding renbody_def renbody_fn_def renbody1_fn_def
  by (rule sats_iff_sats_ren, auto simp add:renbody1_thm(1)[of _ M,simplified]
                                            renbody1_thm(2)[where α=α and m=m,simplified])

context G_generic
begin

lemma pow_inter_M:
  assumes
    "xM" "yM"
  shows
    "powerset(##M,x,y)  y = Pow(x)  M"
  using assms by auto


schematic_goal sats_prebody_fm_auto:
  assumes
    "φformula" "[P,leq,one,p,ρ,π] @ nenv list(M)"  "αM" "arity(φ)  2 #+ length(nenv)"
  shows
    "(τM. VM. is_Vset(##M,α,V)  τV  sats(M,forces(φ),[p,P,leq,one,ρ,τ] @ nenv))
    sats(M,?prebody_fm,[ρ,p,α,P,leq,one] @ nenv)"
  apply (insert assms; (rule sep_rules is_Vset_iff_sats[OF _ _ _ _ _ nonempty[simplified]] | simp))
   apply (rule sep_rules is_Vset_iff_sats is_Vset_iff_sats[OF _ _ _ _ _ nonempty[simplified]] | simp)+
        apply (rule nonempty[simplified])
       apply (simp_all)
    apply (rule length_type[THEN nat_into_Ord], blast)+
  apply ((rule sep_rules | simp))
    apply ((rule sep_rules | simp))
      apply ((rule sep_rules | simp))
       apply ((rule sep_rules | simp))
      apply ((rule sep_rules | simp))
     apply ((rule sep_rules | simp))
    apply ((rule sep_rules | simp))
   apply (rule renrep_sats[simplified])
       apply (insert assms)
       apply(auto simp add: renrep_type definability)
proof -
  from assms
  have "nenvlist(M)" by simp
  with ‹arity(φ)_ φ_
  show "arity(forces(φ))  succ(succ(succ(succ(succ(succ(length(nenv)))))))"
    using arity_forces_le by simp
qed

(* The formula synthesized above *)
synthesize_notc "prebody_fm" from_schematic sats_prebody_fm_auto

lemma prebody_fm_type [TC]:
  assumes "φformula"
    "env  list(M)"
  shows "prebody_fm(φ,env)formula"
proof -
  from φformula›
  have "forces(φ)formula" by simp
  then
  have "renrep(forces(φ),env)formula"
    using envlist(M) by simp
  then show ?thesis unfolding prebody_fm_def by simp
qed

lemmas new_fm_defs = fm_defs is_transrec_fm_def is_eclose_fm_def mem_eclose_fm_def
  finite_ordinal_fm_def is_wfrec_fm_def  Memrel_fm_def eclose_n_fm_def is_recfun_fm_def is_iterates_fm_def
  iterates_MH_fm_def is_nat_case_fm_def quasinat_fm_def pre_image_fm_def restriction_fm_def

lemma sats_prebody_fm:
  assumes
    "[P,leq,one,p,ρ] @ nenv list(M)" "φformula" "αM" "arity(φ)  2 #+ length(nenv)"
  shows
    "sats(M,prebody_fm(φ,nenv),[ρ,p,α,P,leq,one] @ nenv) 
     (τM. VM. is_Vset(##M,α,V)  τV  sats(M,forces(φ),[p,P,leq,one,ρ,τ] @ nenv))"
  unfolding prebody_fm_def using assms sats_prebody_fm_auto by force


lemma arity_prebody_fm:
  assumes
    "φformula" "αM" "env  list(M)" "arity(φ)  2 #+ length(env)"
  shows
    "arity(prebody_fm(φ,env))6 #+ length(env)"
  unfolding prebody_fm_def is_HVfrom_fm_def is_powapply_fm_def
  using assms new_fm_defs nat_simp_union
    arity_renrep[of "forces(φ)"] arity_forces_le[simplified] pred_le by auto


definition
  body_fm' :: "[i,i]i" where
  "body_fm'(φ,env)  Exists(Exists(And(pair_fm(0,1,2),renpbdy(prebody_fm(φ,env),env))))"

lemma body_fm'_type[TC]: "φformula  envlist(M)  body_fm'(φ,env)formula"
  unfolding body_fm'_def using prebody_fm_type
  by simp

lemma arity_body_fm':
  assumes
    "φformula" "αM" "envlist(M)" "arity(φ)  2 #+ length(env)"
  shows
    "arity(body_fm'(φ,env))5  #+ length(env)"
  unfolding body_fm'_def
  using assms new_fm_defs nat_simp_union arity_prebody_fm pred_le  arity_renpbdy[of "prebody_fm(φ,env)"]
  by auto

lemma sats_body_fm':
  assumes
    "t p. x=t,p" "xM" "[α,P,leq,one,p,ρ] @ nenv list(M)" "φformula" "arity(φ)  2 #+ length(nenv)"
  shows
    "sats(M,body_fm'(φ,nenv),[x,α,P,leq,one] @ nenv) 
     sats(M,renpbdy(prebody_fm(φ,nenv),nenv),[fst(x),snd(x),x,α,P,leq,one] @ nenv)"
  using assms fst_snd_closed[OF xM] unfolding body_fm'_def
  by (auto)

definition
  body_fm :: "[i,i]i" where
  "body_fm(φ,env)  renbody(body_fm'(φ,env),env)"

lemma body_fm_type [TC]: "envlist(M)  φformula   body_fm(φ,env)formula"
  unfolding body_fm_def by simp

lemma sats_body_fm:
  assumes
    "t p. x=t,p" "[α,x,m,P,leq,one] @ nenv list(M)"
    "φformula" "arity(φ)  2 #+ length(nenv)"
  shows
    "sats(M,body_fm(φ,nenv),[α,x,m,P,leq,one] @ nenv) 
     sats(M,renpbdy(prebody_fm(φ,nenv),nenv),[fst(x),snd(x),x,α,P,leq,one] @ nenv)"
  using assms sats_body_fm' sats_renbody[OF _ assms(2), symmetric] arity_body_fm'
  unfolding body_fm_def
  by auto

lemma sats_renpbdy_prebody_fm:
  assumes
    "t p. x=t,p" "xM" "[α,m,P,leq,one] @ nenv list(M)"
    "φformula" "arity(φ)  2 #+ length(nenv)"
  shows
    "sats(M,renpbdy(prebody_fm(φ,nenv),nenv),[fst(x),snd(x),x,α,P,leq,one] @ nenv) 
     sats(M,prebody_fm(φ,nenv),[fst(x),snd(x),α,P,leq,one] @ nenv)"
  using assms fst_snd_closed[OF xM]
    sats_renpbdy[OF arity_prebody_fm _ prebody_fm_type, of concl:M, symmetric]
  by force

lemma body_lemma:
  assumes
    "t p. x=t,p" "xM" "[x,α,m,P,leq,one] @ nenv list(M)"
    "φformula" "arity(φ)  2 #+ length(nenv)"
  shows
    "sats(M,body_fm(φ,nenv),[α,x,m,P,leq,one] @ nenv) 
  (τM. VM. is_Vset(λa. (##M)(a),α,V)  τ  V  (snd(x)  φ ([fst(x),τ]@nenv)))"
  using assms sats_body_fm[of x α m nenv] sats_renpbdy_prebody_fm[of x α]
    sats_prebody_fm[of "snd(x)" "fst(x)"] fst_snd_closed[OF xM]
  by (simp, simp flip: setclass_iff,simp)

lemma Replace_sats_in_MG:
  assumes
    "cM[G]" "env  list(M[G])"
    "φ  formula" "arity(φ)  2 #+ length(env)"
    "univalent(##M[G], c, λx v. (M[G] , [x,v]@env  φ) )"
  shows
    "{v. xc, vM[G]  (M[G] , [x,v]@env  φ)}  M[G]"
proof -
  let ?R = "λ x v . vM[G]  (M[G] , [x,v]@env  φ)"
  from cM[G]
  obtain π' where "val(G, π') = c" "π'  M"
    using GenExt_def by auto
  then
  have "domain(π')×PM" (is "M")
    using cartprod_closed P_in_M domain_closed by simp
  from ‹val(G, π') = c
  have "c  val(G,)"
    using def_val[of G ] one_in_P one_in_G[OF generic] elem_of_val
      domain_of_prod[OF one_in_P, of "domain(π')"] by force
  from env  _
  obtain nenv where "nenvlist(M)" "env = map(val(G),nenv)"
    using map_val by auto
  then
  have "length(nenv) = length(env)" by simp
  define f where "f(ρp)  μ α. αM  (τM. τ  Vset(α) 
        (snd(ρp)  φ ([fst(ρp),τ] @ nenv)))" (is "_  μ α. ?P(ρp,α)") for ρp
  have "f(ρp) = (μ α. αM  (τM. VM. is_Vset(##M,α,V)  τV 
        (snd(ρp)  φ ([fst(ρp),τ] @ nenv))))" (is "_ = (μ α. αM  ?Q(ρp,α))") for ρp
    unfolding f_def using Vset_abs Vset_closed Ord_Least_cong[of "?P(ρp)" "λ α. αM  ?Q(ρp,α)"]
    by (simp, simp del:setclass_iff)
  moreover
  have "f(ρp)  M" for ρp
    unfolding f_def using Least_closed[of "?P(ρp)"] by simp
  ultimately
  have 1:"least(##M,λα. ?Q(ρp,α),f(ρp))" for ρp
    using least_abs[of "λα. αM  ?Q(ρp,α)" "f(ρp)"] least_conj
    by (simp flip: setclass_iff)
  have "Ord(f(ρp))" for ρp unfolding f_def by simp
  define QQ where "QQ?Q"
  from 1
  have "least(##M,λα. QQ(ρp,α),f(ρp))" for ρp
    unfolding QQ_def .
  from ‹arity(φ)  _ ‹length(nenv) = _
  have "arity(φ)  2 #+ length(nenv)"
    by simp
  moreover
  note assms nenvlist(M) M
  moreover
  have "ρp  t p. ρp=t,p" for ρp
    by auto
  ultimately
  have body:"M , [α,ρp,m,P,leq,one] @ nenv  body_fm(φ,nenv)  ?Q(ρp,α)"
    if "ρp" "ρpM" "mM" "αM" for α ρp m
    using that P_in_M leq_in_M one_in_M body_lemma[of ρp α m nenv φ] by simp
  let ?f_fm="least_fm(body_fm(φ,nenv),1)"
  {
    fix ρp m
    assume asm: "ρpM" "ρp" "mM"
    note inM = this P_in_M leq_in_M one_in_M nenvlist(M)
    with body
    have body':"α. α  M  (τM. VM. is_Vset(λa. (##M)(a), α, V)  τ  V 
          (snd(ρp)  φ ([fst(ρp),τ] @ nenv))) 
          M, Cons(α, [ρp, m, P, leq, one] @ nenv)  body_fm(φ,nenv)" by simp
    from inM
    have "M , [ρp,m,P,leq,one] @ nenv  ?f_fm  least(##M, QQ(ρp), m)"
      using sats_least_fm[OF body', of 1] unfolding QQ_def
      by (simp, simp flip: setclass_iff)
  }
  then
  have "M, [ρp,m,P,leq,one] @ nenv  ?f_fm  least(##M, QQ(ρp), m)"
    if "ρpM" "ρp" "mM" for ρp m using that by simp
  then
  have "univalent(##M, , λρp m. M , [ρp,m] @ ([P,leq,one] @ nenv)  ?f_fm)"
    unfolding univalent_def by (auto intro:unique_least)
  moreover from ‹length(_) = _ env  _
  have "length([P,leq,one] @ nenv) = 3 #+ length(env)" by simp
  moreover from ‹arity(_)  2 #+ length(nenv)
    ‹length(_) = length(_)[symmetric] nenv_ φ_
  have "arity(?f_fm)  5 #+ length(env)"
    unfolding body_fm_def  new_fm_defs least_fm_def
    using arity_forces arity_renrep arity_renbody arity_body_fm' nonempty
    by (simp add: pred_Un Un_assoc, simp add: Un_assoc[symmetric] nat_union_abs1 pred_Un)
      (auto simp add: nat_simp_union, rule pred_le, auto intro:leI)
  moreover from φformula› nenvlist(M)
  have "?f_fmformula" by simp
  moreover
  note inM = P_in_M leq_in_M one_in_M nenvlist(M) M
  ultimately
  obtain Y where "YM"
    "mM. m  Y  (ρpM. ρp    M, [ρp,m] @ ([P,leq,one] @ nenv)  ?f_fm)"
    using replacement_ax[of ?f_fm "[P,leq,one] @ nenv"]
    unfolding strong_replacement_def by auto
  with ‹least(_,QQ(_),f(_)) f(_)  M M
    _  _  _  M,_  ?f_fm  least(_,_,_)
  have "f(ρp)Y" if "ρp" for ρp
    using that transitivity[OF _ M]
    by (clarsimp, rule_tac x="x,y" in bexI, auto)
  moreover
  have "{yY. Ord(y)}  M"
    using YM separation_ax sats_ordinal_fm trans_M
      separation_cong[of "##M" "λy. sats(M,ordinal_fm(0),[y])" "Ord"]
      separation_closed by simp
  then
  have " {yY. Ord(y)}  M" (is "?sup  M")
    using Union_closed by simp
  then
  have "{xVset(?sup). x  M}  M"
    using Vset_closed by simp
  moreover
  have "{one}  M"
    using one_in_M singletonM by simp
  ultimately
  have "{xVset(?sup). x  M} × {one}  M" (is "?big_name  M")
    using cartprod_closed by simp
  then
  have "val(G,?big_name)  M[G]"
    by (blast intro:GenExtI)
  {
    fix v x
    assume "xc"
    moreover
    note ‹val(G,π')=c π'M
    moreover
    from calculation
    obtain ρ p where "ρ,pπ'"  "val(G,ρ) = x" "pG" "ρM"
      using elem_of_val_pair'[of π' x G] by blast
    moreover
    assume "vM[G]"
    then
    obtain σ where "val(G,σ) = v" "σM"
      using GenExtD by auto
    moreover
    assume "sats(M[G], φ, [x,v] @ env)"
    moreover
    note φ_ nenv_ env = _ ‹arity(φ) 2 #+ length(env)
    ultimately
    obtain q where "qG" "q  φ ([ρ,σ]@nenv)"
      using truth_lemma[OF φ_ generic, symmetric, of "[ρ,σ] @ nenv"]
      by auto
    with ρ,pπ' ρ,q  f(ρ,q)Y
    have "f(ρ,q)Y"
      using generic unfolding M_generic_def filter_def by blast
    let ="succ(rank(σ))"
    note σM
    moreover from this
    have "  M"
      using rank_closed cons_closed by (simp flip: setclass_iff)
    moreover
    have "σ  Vset()"
      using Vset_Ord_rank_iff by auto
    moreover
    note q  φ ([ρ,σ] @ nenv)
    ultimately
    have "?P(ρ,q,)" by (auto simp del: Vset_rank_iff)
    moreover
    have "(μ α. ?P(ρ,q,α)) = f(ρ,q)"
      unfolding f_def by simp
    ultimately
    obtain τ where "τM" "τ  Vset(f(ρ,q))" "q  φ ([ρ,τ] @ nenv)"
      using LeastI[of "λ α. ?P(ρ,q,α)" ] by auto
    with qG ρM nenv_ ‹arity(φ) 2 #+ length(nenv)
    have "M[G], map(val(G),[ρ,τ] @ nenv)  φ"
      using truth_lemma[OF φ_ generic, of "[ρ,τ] @ nenv"] by auto
    moreover from xc cM[G]
    have "xM[G]" using transitivity_MG by simp
    moreover
    note M[G],[x,v] @ env φ env = map(val(G),nenv) τM ‹val(G,ρ)=x
      ‹univalent(##M[G],_,_) xc vM[G]
    ultimately
    have "v=val(G,τ)"
      using GenExtI[of τ G] unfolding univalent_def by (auto)
    from τ  Vset(f(ρ,q)) ‹Ord(f(_))  f(ρ,q)Y
    have "τ  Vset(?sup)"
      using Vset_Ord_rank_iff lt_Union_iff[of _ "rank(τ)"] by auto
    with τM
    have "val(G,τ)  val(G,?big_name)"
      using domain_of_prod[of one "{one}" "{xVset(?sup). x  M}" ] def_val[of G ?big_name]
        one_in_G[OF generic] one_in_P  by (auto simp del: Vset_rank_iff)
    with v=val(G,τ)
    have "v  val(G,{xVset(?sup). x  M} × {one})"
      by simp
  }
  then
  have "{v. xc, ?R(x,v)}  val(G,?big_name)" (is "?repl?big")
    by blast
  with ?big_nameM
  have "?repl = {v?big. xc. sats(M[G], φ, [x,v] @ env )}" (is "_ = ?rhs")
  proof(intro equalityI subsetI)
    fix v
    assume "v?repl"
    with ?repl?big
    obtain x where "xc" "M[G], [x, v] @ env  φ" "v?big"
      using subsetD by auto
    with ‹univalent(##M[G],_,_) cM[G]
    show "v  ?rhs"
      unfolding univalent_def
      using transitivity_MG ReplaceI[of "λ x v. xc. M[G], [x, v] @ env  φ"] by blast
  next
    fix v
    assume "v?rhs"
    then
    obtain x where
      "vval(G, ?big_name)" "M[G], [x, v] @ env  φ" "xc"
      by blast
    moreover from this cM[G]
    have "vM[G]" "xM[G]"
      using transitivity_MG GenExtI[OF ?big_name_,of G] by auto
    moreover from calculation ‹univalent(##M[G],_,_)
    have "?R(x,y)  y = v" for y
      unfolding univalent_def by auto
    ultimately
    show "v?repl"
      using ReplaceI[of ?R x v c]
      by blast
  qed
  moreover
  let  = "Exists(And(Member(0,2#+length(env)),φ))"
  have "vM[G]  (xc. M[G], [x,v] @ env  φ)  M[G], [v] @ env @ [c]  "
    "arity()  2 #+ length(env)" "formula"
    for v
  proof -
    fix v
    assume "vM[G]"
    with cM[G]
    have "nth(length(env)#+1,[v]@env@[c]) = c"
      using  env_nth_concat[of v c "M[G]" env]
      by auto
    note inMG= ‹nth(length(env)#+1,[v]@env@[c]) = c cM[G] vM[G] env_
    show "(xc. M[G], [x,v] @ env  φ)  M[G], [v] @ env @ [c]  "
    proof
      assume "xc. M[G], [x, v] @ env  φ"
      then obtain x where
        "xc" "M[G], [x, v] @ env  φ" "xM[G]"
        using transitivity_MG[OF _ cM[G]]
        by auto
      with φ_ ‹arity(φ)2#+length(env) inMG
      show "M[G], [v] @ env @ [c]  Exists(And(Member(0, 2 #+ length(env)), φ))"
        using arity_sats_iff[of φ "[c]" _ "[x,v]@env"]
        by auto
    next
      assume "M[G], [v] @ env @ [c]  Exists(And(Member(0, 2 #+ length(env)), φ))"
      with inMG
      obtain x where
        "xM[G]" "xc" "M[G], [x,v]@env@[c]  φ"
        by auto
      with φ_ ‹arity(φ)2#+length(env) inMG
      show "xc. M[G], [x, v] @ env φ"
        using arity_sats_iff[of φ "[c]" _ "[x,v]@env"]
        by auto
    qed
  next
    from env_ φ_
    show "arity()2#+length(env)"
      using pred_mono[OF _ ‹arity(φ)2#+length(env)] lt_trans[OF _ le_refl]
      by (auto simp add:nat_simp_union)
  next
    from φ_
    show "formula" by simp
  qed
  moreover from this
  have "{v?big. xc. M[G], [x,v] @ env  φ} = {v?big. M[G], [v] @ env @ [c]   }"
    using transitivity_MG[OF _ GenExtI, OF _ ?big_nameM]
    by simp
  moreover from calculation and env_ c_ ?bigM[G]
  have "{v?big. M[G] , [v] @ env @ [c]  }  M[G]"
    using Collect_sats_in_MG by auto
  ultimately
  show ?thesis by simp
qed

theorem strong_replacement_in_MG:
  assumes
    "φformula" and "arity(φ)  2 #+ length(env)" "env  list(M[G])"
  shows
    "strong_replacement(##M[G],λx v. sats(M[G],φ,[x,v] @ env))"
proof -
  let ?R="λx y . M[G], [x, y] @ env  φ"
  {
    fix A
    let ?Y="{v . x  A, vM[G]  ?R(x,v)}"
    assume 1: "(##M[G])(A)"
      "x[##M[G]]. x  A  (y[##M[G]]. z[##M[G]]. ?R(x,y)  ?R(x,z)  y = z)"
    then
    have "univalent(##M[G], A, ?R)" "AM[G]"
      unfolding univalent_def by simp_all
    with assms A_
    have "(##M[G])(?Y)"
      using Replace_sats_in_MG by auto
    have "b  ?Y  (x[##M[G]]. x  A  ?R(x,b))" if "(##M[G])(b)" for b
    proof(rule)
      from A_
      show "x[##M[G]]. x  A  ?R(x,b)" if "b  ?Y"
        using that transitivity_MG by auto
    next
      show "b  ?Y" if "x[##M[G]]. x  A  ?R(x,b)"
      proof -
        from (##M[G])(b)
        have "bM[G]" by simp
        with that
        obtain x where "(##M[G])(x)" "xA" "bM[G]  ?R(x,b)"
          by blast
        moreover from this 1 (##M[G])(b)
        have "xM[G]" "zM[G]  ?R(x,z)  b = z" for z
          by auto
        ultimately
        show ?thesis
          using ReplaceI[of "λ x y. yM[G]  ?R(x,y)"] by auto
      qed
    qed
    then
    have "b[##M[G]]. b  ?Y  (x[##M[G]]. x  A  ?R(x,b))"
      by simp
    with (##M[G])(?Y)
    have " (Y[##M[G]]. b[##M[G]]. b  Y  (x[##M[G]]. x  A  ?R(x,b)))"
      by auto
  }
  then show ?thesis unfolding strong_replacement_def univalent_def
    by auto
qed

end (* context G_generic *)

end

Theory Infinity_Axiom

section‹The Axiom of Infinity in $M[G]$›
theory Infinity_Axiom
  imports Pairing_Axiom Union_Axiom Separation_Axiom
begin

context G_generic begin

interpretation mg_triv: M_trivial"##M[G]"
  using transitivity_MG zero_in_MG generic Union_MG pairing_in_MG
  by unfold_locales auto

lemma infinity_in_MG : "infinity_ax(##M[G])"
proof -
  from infinity_ax obtain I where
    Eq1: "IM" "0  I" "yM. y  I  succ(y)  I"
    unfolding infinity_ax_def  by auto
  then
  have "check(I)  M"
    using check_in_M by simp
  then
  have "I M[G]"
    using valcheck generic one_in_G one_in_P GenExtI[of "check(I)" G] by simp
  with 0I
  have "0M[G]" using transitivity_MG by simp
  with IM
  have "y  M" if "y  I" for y
    using  transitivity[OF _ IM] that by simp
  with IM[G]
  have "succ(y)  I  M[G]" if "y  I" for y
    using that Eq1 transitivity_MG by blast
  with Eq1 IM[G] 0M[G]
  show ?thesis
    unfolding infinity_ax_def by auto
qed

end (* G_generic' *)
end

Theory Choice_Axiom

section‹The Axiom of Choice in $M[G]$›
theory Choice_Axiom
  imports Powerset_Axiom Pairing_Axiom Union_Axiom Extensionality_Axiom 
          Foundation_Axiom Powerset_Axiom Separation_Axiom 
          Replacement_Axiom Interface Infinity_Axiom
begin

definition 
  induced_surj :: "iiii" where
  "induced_surj(f,a,e)  f-``(range(f)-a)×{e}  restrict(f,f-``a)"
  
lemma domain_induced_surj: "domain(induced_surj(f,a,e)) = domain(f)"
  unfolding induced_surj_def using domain_restrict domain_of_prod by auto
    
lemma range_restrict_vimage: 
  assumes "function(f)"
  shows "range(restrict(f,f-``a))  a"
proof
  from assms 
  have "function(restrict(f,f-``a))" 
    using function_restrictI by simp
  fix y
  assume "y  range(restrict(f,f-``a))"
  then 
  obtain x where "x,y  restrict(f,f-``a)"  "x  f-``a" "xdomain(f)"
    using domain_restrict domainI[of _ _ "restrict(f,f-``a)"] by auto
  moreover 
  note ‹function(restrict(f,f-``a)) 
  ultimately 
  have "y = restrict(f,f-``a)`x" 
    using function_apply_equality by blast
  also from x  f-``a 
  have "restrict(f,f-``a)`x = f`x" 
    by simp
  finally 
  have "y=f`x" .
  moreover from assms xdomain(f) 
  have "x,f`x  f" 
    using function_apply_Pair by auto 
  moreover 
  note assms x  f-``a 
  ultimately 
  show "ya"
    using function_image_vimage[of f a] by auto
qed
  
lemma induced_surj_type: 
  assumes
    "function(f)" (* "relation(f)" (* a function can contain nonpairs *) *)
  shows 
    "induced_surj(f,a,e): domain(f)  {e}  a"
    and
    "x  f-``a  induced_surj(f,a,e)`x = f`x" 
proof -
  let ?f1="f-``(range(f)-a) × {e}" and ?f2="restrict(f, f-``a)"
  have "domain(?f2) = domain(f)  f-``a"
    using domain_restrict by simp
  moreover from assms 
  have 1: "domain(?f1) = f-``(range(f))-f-``a"
    using domain_of_prod function_vimage_Diff by simp
  ultimately 
  have "domain(?f1)  domain(?f2) = 0"
    by auto
  moreover 
  have "function(?f1)" "relation(?f1)" "range(?f1)  {e}"
    unfolding function_def relation_def range_def by auto
  moreover from this and assms 
  have "?f1: domain(?f1)  range(?f1)"
    using function_imp_Pi by simp
  moreover from assms 
  have "?f2: domain(?f2)  range(?f2)"
    using function_imp_Pi[of "restrict(f, f -`` a)"] function_restrictI by simp
  moreover from assms 
  have "range(?f2)  a" 
    using range_restrict_vimage by simp
  ultimately 
  have "induced_surj(f,a,e): domain(?f1)  domain(?f2)  {e}  a"
    unfolding induced_surj_def using fun_is_function fun_disjoint_Un fun_weaken_type by simp
  moreover 
  have "domain(?f1)  domain(?f2) = domain(f)"
    using domain_restrict domain_of_prod by auto 
  ultimately
  show "induced_surj(f,a,e): domain(f)  {e}  a"
    by simp
  assume "x  f-``a"
  then 
  have "?f2`x = f`x"
    using restrict by simp
  moreover from x  f-``a and 1 
  have "x  domain(?f1)"
    by simp
  ultimately 
  show "induced_surj(f,a,e)`x = f`x" 
    unfolding induced_surj_def using fun_disjoint_apply2[of x ?f1 ?f2] by simp
qed
  
lemma induced_surj_is_surj : 
  assumes 
    "ea" "function(f)" "domain(f) = α" "y. y  a  xα. f ` x = y" 
  shows
    "induced_surj(f,a,e)  surj(α,a)"
  unfolding surj_def
proof (intro CollectI ballI)
  from assms 
  show "induced_surj(f,a,e): α  a"
    using induced_surj_type[of f a e] cons_eq cons_absorb by simp
  fix y
  assume "y  a"
  with assms 
  have "xα. f ` x = y" 
    by simp
  then
  obtain x where "xα" "f ` x = y" by auto
  with ya assms
  have "xf-``a" 
    using vimage_iff function_apply_Pair[of f x] by auto
  with f ` x = y assms
  have "induced_surj(f, a, e) ` x = y"
    using induced_surj_type by simp
  with xα show
    "xα. induced_surj(f, a, e) ` x = y" by auto
qed
  
context G_generic 
begin

definition
  upair_name :: "i  i  i" where
  "upair_name(τ,ρ)  {τ,one,ρ,one}"

definition
  is_upair_name :: "[i,i,i]  o" where
  "is_upair_name(x,y,z)  xoM. yoM. pair(##M,x,one,xo)  pair(##M,y,one,yo)  
                                       upair(##M,xo,yo,z)"

lemma upair_name_abs : 
  assumes "xM" "yM" "zM" 
  shows "is_upair_name(x,y,z)  z = upair_name(x,y)" 
  unfolding is_upair_name_def upair_name_def using assms one_in_M pair_in_M_iff by simp

lemma upair_name_closed :
  " xM; yM   upair_name(x,y)M" 
  unfolding upair_name_def using upair_in_M_iff pair_in_M_iff one_in_M by simp

definition
  upair_name_fm :: "[i,i,i,i]  i" where
  "upair_name_fm(x,y,o,z)  Exists(Exists(And(pair_fm(x#+2,o#+2,1),
                                          And(pair_fm(y#+2,o#+2,0),upair_fm(1,0,z#+2)))))" 

lemma upair_name_fm_type[TC] :
    " snat;xnat;ynat;onat  upair_name_fm(s,x,y,o)formula"
  unfolding upair_name_fm_def by simp

lemma sats_upair_name_fm :
  assumes "xnat" "ynat" "znat" "onat" "envlist(M)""nth(o,env)=one" 
  shows 
    "sats(M,upair_name_fm(x,y,o,z),env)  is_upair_name(nth(x,env),nth(y,env),nth(z,env))"
  unfolding upair_name_fm_def is_upair_name_def using assms by simp

definition
  opair_name :: "i  i  i" where
  "opair_name(τ,ρ)  upair_name(upair_name(τ,τ),upair_name(τ,ρ))"

definition
  is_opair_name :: "[i,i,i]  o" where
  "is_opair_name(x,y,z)  upxxM. upxyM. is_upair_name(x,x,upxx)  is_upair_name(x,y,upxy)
                                           is_upair_name(upxx,upxy,z)" 

lemma opair_name_abs : 
  assumes "xM" "yM" "zM" 
  shows "is_opair_name(x,y,z)  z = opair_name(x,y)" 
  unfolding is_opair_name_def opair_name_def using assms upair_name_abs upair_name_closed by simp

lemma opair_name_closed :
  " xM; yM   opair_name(x,y)M" 
  unfolding opair_name_def using upair_name_closed by simp

definition
  opair_name_fm :: "[i,i,i,i]  i" where
  "opair_name_fm(x,y,o,z)  Exists(Exists(And(upair_name_fm(x#+2,x#+2,o#+2,1),
                    And(upair_name_fm(x#+2,y#+2,o#+2,0),upair_name_fm(1,0,o#+2,z#+2)))))" 

lemma opair_name_fm_type[TC] :
    " snat;xnat;ynat;onat  opair_name_fm(s,x,y,o)formula"
  unfolding opair_name_fm_def by simp

lemma sats_opair_name_fm :
  assumes "xnat" "ynat" "znat" "onat" "envlist(M)""nth(o,env)=one" 
  shows 
    "sats(M,opair_name_fm(x,y,o,z),env)  is_opair_name(nth(x,env),nth(y,env),nth(z,env))"
  unfolding opair_name_fm_def is_opair_name_def using assms sats_upair_name_fm by simp

lemma val_upair_name : "val(G,upair_name(τ,ρ)) = {val(G,τ),val(G,ρ)}"
  unfolding upair_name_def using val_Upair  generic one_in_G one_in_P by simp
    
lemma val_opair_name : "val(G,opair_name(τ,ρ)) = val(G,τ),val(G,ρ)"
  unfolding opair_name_def Pair_def using val_upair_name  by simp
    
lemma val_RepFun_one: "val(G,{f(x),one . xa}) = {val(G,f(x)) . xa}"
proof -
  let ?A = "{f(x) . x  a}"
  let ?Q = "λx,p . p = one"
  have "one  PG" using generic one_in_G one_in_P by simp
  have "{f(x),one . x  a} = {t  ?A × P . ?Q(t)}" 
    using one_in_P by force
  then
  have "val(G,{f(x),one  . x  a}) = val(G,{t  ?A × P . ?Q(t)})"
    by simp
  also
  have "... = {val(G,t) .. t  ?A , pPG . ?Q(t,p)}"
    using val_of_name_alt by simp
  also
  have "... = {val(G,t) . t  ?A }"
    using onePG by force
  also
  have "... = {val(G,f(x)) . x  a}"
    by auto
  finally show ?thesis by simp
qed

subsection‹$M[G]$ is a transitive model of ZF›

interpretation mgzf: M_ZF_trans "M[G]"
  using Transset_MG generic pairing_in_MG Union_MG 
    extensionality_in_MG power_in_MG foundation_in_MG  
    strong_replacement_in_MG separation_in_MG infinity_in_MG
  by unfold_locales simp_all

(* y = opair_name(check(β),s`β) *)
definition
  is_opname_check :: "[i,i,i]  o" where
  "is_opname_check(s,x,y)  chxM. sxM. is_check(x,chx)  fun_apply(##M,s,x,sx)  
                             is_opair_name(chx,sx,y)" 

definition
  opname_check_fm :: "[i,i,i,i]  i" where
  "opname_check_fm(s,x,y,o)  Exists(Exists(And(check_fm(2#+x,2#+o,1),
                              And(fun_apply_fm(2#+s,2#+x,0),opair_name_fm(1,0,2#+o,2#+y)))))"

lemma opname_check_fm_type[TC] :
  " snat;xnat;ynat;onat  opname_check_fm(s,x,y,o)formula"
  unfolding opname_check_fm_def by simp

lemma sats_opname_check_fm:
  assumes "xnat" "ynat" "znat" "onat" "envlist(M)" "nth(o,env)=one" 
          "y<length(env)"
  shows 
    "sats(M,opname_check_fm(x,y,z,o),env)  is_opname_check(nth(x,env),nth(y,env),nth(z,env))"
  unfolding opname_check_fm_def is_opname_check_def 
  using assms sats_check_fm sats_opair_name_fm one_in_M by simp


lemma opname_check_abs :
  assumes "sM" "xM" "yM" 
  shows "is_opname_check(s,x,y)  y = opair_name(check(x),s`x)" 
  unfolding is_opname_check_def  
  using assms check_abs check_in_M opair_name_abs apply_abs apply_closed by simp

lemma repl_opname_check :
  assumes
    "AM" "fM" 
  shows
   "{opair_name(check(x),f`x). xA}M"
proof -
  have "arity(opname_check_fm(3,0,1,2))= 4" 
    unfolding opname_check_fm_def opair_name_fm_def upair_name_fm_def
          check_fm_def rcheck_fm_def trans_closure_fm_def is_eclose_fm_def mem_eclose_fm_def
         is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def finite_ordinal_fm_def is_iterates_fm_def
             is_wfrec_fm_def is_recfun_fm_def restriction_fm_def pre_image_fm_def eclose_n_fm_def
        is_nat_case_fm_def quasinat_fm_def Memrel_fm_def singleton_fm_def fm_defs iterates_MH_fm_def
    by (simp add:nat_simp_union)
  moreover
  have "xA  opair_name(check(x), f ` x)M" for x
    using assms opair_name_closed apply_closed transitivity check_in_M
    by simp
  ultimately
  show ?thesis using assms opname_check_abs[of f] sats_opname_check_fm
        one_in_M
        Repl_in_M[of "opname_check_fm(3,0,1,2)" "[one,f]" "is_opname_check(f)" 
                    "λx. opair_name(check(x),f`x)"] 
    by simp
qed



theorem choice_in_MG: 
  assumes "choice_ax(##M)"
  shows "choice_ax(##M[G])"
proof -
  {
    fix a
    assume "aM[G]"
    then
    obtain τ where "τM" "val(G,τ) = a" 
      using GenExt_def by auto
    with τM
    have "domain(τ)M"
      using domain_closed by simp
    then
    obtain s α where "ssurj(α,domain(τ))" "Ord(α)" "sM" "αM"
      using assms choice_ax_abs by auto
    then
    have "αM[G]"         
      using M_subset_MG generic one_in_G subsetD by blast
    let ?A="domain(τ)×P"
    let ?g = "{opair_name(check(β),s`β). βα}"
    have "?g  M" using sM αM repl_opname_check by simp
    let ?f_dot="{opair_name(check(β),s`β),one. βα}"
    have "?f_dot = ?g × {one}" by blast
    from one_in_M have "{one}  M" using singletonM by simp
    define f where
      "f  val(G,?f_dot)" 
    from {one}M ?gM ?f_dot = ?g×{one} 
    have "?f_dotM" 
      using cartprod_closed by simp
    then
    have "f  M[G]"
      unfolding f_def by (blast intro:GenExtI)
    have "f = {val(G,opair_name(check(β),s`β)) . βα}"
      unfolding f_def using val_RepFun_one by simp
    also
    have "... = {β,val(G,s`β) . βα}"
      using val_opair_name valcheck generic one_in_G one_in_P by simp
    finally
    have "f = {β,val(G,s`β) . βα}" .
    then
    have 1: "domain(f) = α" "function(f)"
      unfolding function_def by auto
    have 2: "y  a  xα. f ` x = y" for y
    proof -
      fix y
      assume
        "y  a"
      with ‹val(G,τ) = a 
      obtain σ where  "σdomain(τ)" "val(G,σ) = y"
        using elem_of_val[of y _ τ] by blast
      with ssurj(α,domain(τ)) 
      obtain β where "βα" "s`β = σ" 
        unfolding surj_def by auto
      with ‹val(G,σ) = y
      have "val(G,s`β) = y" 
        by simp
      with f = {β,val(G,s`β) . βα} βα
      have "β,yf" 
        by auto
      with ‹function(f)
      have "f`β = y"
        using function_apply_equality by simp
      with βα show
        "βα. f ` β = y" 
        by auto
    qed
    then
    have "α(M[G]). f'(M[G]). Ord(α)  f'  surj(α,a)"
    proof (cases "a=0")
      case True
      then
      have "0surj(0,a)" 
        unfolding surj_def by simp
      then
      show ?thesis using zero_in_MG by auto
    next
      case False
      with aM[G] 
      obtain e where "ea" "eM[G]" 
        using transitivity_MG by blast
      with 1 and 2
      have "induced_surj(f,a,e)  surj(α,a)"
        using induced_surj_is_surj by simp
      moreover from fM[G] aM[G] eM[G]
      have "induced_surj(f,a,e)  M[G]"
        unfolding induced_surj_def 
        by (simp flip: setclass_iff)
      moreover note
        αM[G] ‹Ord(α)
      ultimately show ?thesis by auto
    qed
  }
  then
  show ?thesis using mgzf.choice_ax_abs by simp
qed
  
end (* G_generic_extra_repl *)
  
end

Theory Ordinals_In_MG

section‹Ordinals in generic extensions›
theory Ordinals_In_MG
  imports
    Forcing_Theorems Relative_Univ
begin

context G_generic
begin

lemma rank_val: "rank(val(G,x))  rank(x)" (is "?Q(x)")
proof (induct rule:ed_induction[of ?Q])
  case (1 x)
  have "val(G,x) = {val(G,u). u{tdomain(x). pP .  t,px  p  G }}"
    using def_val unfolding Sep_and_Replace by blast
  then
  have "rank(val(G,x)) = (u{tdomain(x). pP .  t,px  p  G }. succ(rank(val(G,u))))"
    using rank[of "val(G,x)"] by simp
  moreover
  have "succ(rank(val(G, y)))  rank(x)" if "ed(y, x)" for y 
    using 1[OF that] rank_ed[OF that] by (auto intro:lt_trans1)
  moreover from this
  have "(u{tdomain(x). pP .  t,px  p  G }. succ(rank(val(G,u))))  rank(x)" 
    by (rule_tac UN_least_le) (auto)
  ultimately
  show ?case by simp
qed

lemma Ord_MG_iff:
  assumes "Ord(α)" 
  shows "α  M  α  M[G]"
proof
  show "α  M  α  M[G]" 
    using generic[THEN one_in_G, THEN M_subset_MG] ..
next
  assume "α  M[G]"
  then
  obtain x where "xM" "val(G,x) = α"
    using GenExtD by auto
  then
  have "rank(α)  rank(x)" 
    using rank_val by blast
  with assms
  have "α  rank(x)"
    using rank_of_Ord by simp
  then 
  have "α  succ(rank(x))" using ltD by simp
  with xM
  show "α  M"
    using cons_closed transitivity[of α "succ(rank(x))"] 
      rank_closed unfolding succ_def by simp  
qed
  
end (* G_generic *)

end

Theory Proper_Extension

section‹Separative notions and proper extensions›
theory Proper_Extension
  imports
    Names

begin

text‹The key ingredient to obtain a proper extension is to have
a ‹separative preorder›:›

locale separative_notion = forcing_notion +
  assumes separative: "pP  qP. rP. q  p  r  p  q  r"
begin

text‹For separative preorders, the complement of every filter is
dense. Hence an $M$-generic filter can't belong to the ground model.›

lemma filter_complement_dense:
  assumes "filter(G)" shows "dense(P - G)"
proof
  fix p
  assume "pP"
  show "dP - G. d  p"
  proof (cases "pG")
    case True
    note pP assms
    moreover
    obtain q r where "q  p" "r  p" "q  r" "qP" "rP" 
      using separative[OF pP]
      by force
    with ‹filter(G)
    obtain s where "s  p" "s  G" "s  P"
      using filter_imp_compat[of G q r]
      by auto
    then
    show ?thesis by blast
  next
    case False
    with pP 
    show ?thesis using leq_reflI unfolding Diff_def by auto
  qed
qed

end (* separative_notion *)

locale ctm_separative = forcing_data + separative_notion
begin

lemma generic_not_in_M: assumes "M_generic(G)"  shows "G  M"
proof
  assume "GM"
  then
  have "P - G  M" 
    using P_in_M Diff_closed by simp
  moreover
  have "¬(qG. q  P - G)" "(P - G)  P"
    unfolding Diff_def by auto
  moreover
  note assms
  ultimately
  show "False"
    using filter_complement_dense[of G] M_generic_denseD[of G "P-G"] 
      M_generic_def by simp ― ‹need to put generic ==> filter in claset›
qed

theorem proper_extension: assumes "M_generic(G)" shows "M  M[G]"
  using assms G_in_Gen_Ext[of G] one_in_G[of G] generic_not_in_M
  by force

end (* ctm_separative *)

end

Theory Succession_Poset

section‹A poset of successions›
theory Succession_Poset
  imports
    Arities Proper_Extension Synthetic_Definition
    Names
begin

subsection‹The set of finite binary sequences›

text‹We implement the poset for adding one Cohen real, the set 
$2^{<\omega}$ of of finite binary sequences.›

definition
  seqspace :: "i  i" ("_^<ω" [100]100) where
  "seqspace(B)  nnat. (nB)"

lemma seqspaceI[intro]: "nnat  f:nB  fseqspace(B)"
  unfolding seqspace_def by blast

lemma seqspaceD[dest]: "fseqspace(B)  nnat. f:nB"
  unfolding seqspace_def by blast

lemma seqspace_type: 
  "f  B^<ω  nnat. f:nB" 
  unfolding seqspace_def by auto

schematic_goal seqspace_fm_auto:
  assumes 
    "nth(i,env) = n" "nth(j,env) = z"  "nth(h,env) = B" 
    "i  nat" "j  nat" "hnat" "env  list(A)"
  shows 
    "(omA. omega(##A,om)  n  om  is_funspace(##A, n, B, z))  (A, env  (?sqsprp(i,j,h)))"
  unfolding is_funspace_def 
  by (insert assms ; (rule sep_rules | simp)+)

synthesize "seqspace_rep_fm" from_schematic seqspace_fm_auto
 
locale M_seqspace =  M_trancl +
  assumes 
    seqspace_replacement: "M(B)  strong_replacement(M,λn z. nnat  is_funspace(M,n,B,z))"
begin

lemma seqspace_closed:
  "M(B)  M(B^<ω)"
  unfolding seqspace_def using seqspace_replacement[of B] RepFun_closed2 
  by simp

end (* M_seqspace *)


sublocale M_ctm  M_seqspace "##M"
proof (unfold_locales, simp)
  fix B
  have "arity(seqspace_rep_fm(0,1,2))  3" "seqspace_rep_fm(0,1,2)formula" 
    unfolding seqspace_rep_fm_def 
    using arity_pair_fm arity_omega_fm arity_typed_function_fm nat_simp_union 
    by auto
  moreover
  assume "BM"
  ultimately
  have "strong_replacement(##M, λx y. M, [x, y, B]  seqspace_rep_fm(0, 1, 2))"
    using replacement_ax[of "seqspace_rep_fm(0,1,2)"]
    by simp
  moreover 
  note BM
  moreover from this
  have "univalent(##M, A, λx y. M, [x, y, B]  seqspace_rep_fm(0, 1, 2))" 
    if "AM" for A 
    using that unfolding univalent_def seqspace_rep_fm_def  
    by (auto, blast dest:transitivity)
  ultimately
  have "strong_replacement(##M, λn z. om[##M]. omega(##M,om)  n  om  is_funspace(##M, n, B, z))"
    using seqspace_fm_auto[of 0 "[_,_,B]" _ 1 _ 2 B M] unfolding seqspace_rep_fm_def strong_replacement_def
    by simp
  with BM 
  show "strong_replacement(##M, λn z. n  nat  is_funspace(##M, n, B, z))"
    using M_nat by simp
qed

definition seq_upd :: "i  i  i" where
  "seq_upd(f,a)  λ j  succ(domain(f)) . if j < domain(f) then f`j else a"

lemma seq_upd_succ_type : 
  assumes "nnat" "fnA" "aA"
  shows "seq_upd(f,a) succ(n)  A"
proof -
  from assms
  have equ: "domain(f) = n" using domain_of_fun by simp
  {
    fix j
    assume "jsucc(domain(f))"
    with equ n_
    have "jn" using ltI by auto
    with n_
    consider (lt) "j<n" | (eq) "j=n" using leD by auto
    then 
    have "(if j < n then f`j else a)  A"
    proof cases
      case lt
      with f_ 
      show ?thesis using apply_type ltD[OF lt] by simp
    next
      case eq
      with a_
      show ?thesis by auto
    qed
  }
  with equ
  show ?thesis
    unfolding seq_upd_def
    using lam_type[of "succ(domain(f))"]
    by auto
qed

lemma seq_upd_type : 
  assumes "fA^<ω" "aA"
  shows "seq_upd(f,a)  A^<ω"
proof -
  from f_
  obtain y where "ynat" "fyA"
    unfolding seqspace_def by blast
  with aA
  have "seq_upd(f,a)succ(y)A" 
    using seq_upd_succ_type by simp
  with y_
  show ?thesis
    unfolding seqspace_def by auto
qed

lemma seq_upd_apply_domain [simp]: 
  assumes "f:nA" "nnat"
  shows "seq_upd(f,a)`n = a"
  unfolding seq_upd_def using assms domain_of_fun by auto

lemma zero_in_seqspace : 
  shows "0  A^<ω"
  unfolding seqspace_def
  by force

definition
  seqleR :: "i  i  o" where
  "seqleR(f,g)  g  f"

definition
  seqlerel :: "i  i" where
  "seqlerel(A)  Rrel(λx y. y  x,A^<ω)"

definition
  seqle :: "i" where
  "seqle  seqlerel(2)"

lemma seqleI[intro!]: 
  "f,g  2^<ω×2^<ω  g  f   f,g  seqle"
  unfolding  seqspace_def seqle_def seqlerel_def Rrel_def 
  by blast

lemma seqleD[dest!]: 
  "z  seqle  x y. x,y  2^<ω×2^<ω  y  x  z = x,y"
  unfolding seqle_def seqlerel_def Rrel_def 
  by blast

lemma upd_leI : 
  assumes "f2^<ω" "a2"
  shows "seq_upd(f,a),fseqle"  (is "?f,__")
proof
  show " ?f, f  2^<ω × 2^<ω" 
    using assms seq_upd_type by auto
next
  show  "f  seq_upd(f,a)" 
  proof 
    fix x
    assume "x  f"
    moreover from f  2^<ω
    obtain n where  "nnat" "f : n  2"
      using seqspace_type by blast
    moreover from calculation
    obtain y where "yn" "x=y,f`y" using Pi_memberD[of f n "λ_ . 2"] 
      by blast
    moreover from f:n2
    have "domain(f) = n" using domain_of_fun by simp
    ultimately
    show "x  seq_upd(f,a)"
      unfolding seq_upd_def lam_def  
      by (auto intro:ltI)
  qed
qed

lemma preorder_on_seqle: "preorder_on(2^<ω,seqle)"
  unfolding preorder_on_def refl_def trans_on_def by blast

lemma zero_seqle_max: "x2^<ω  x,0  seqle"
  using zero_in_seqspace 
  by auto

interpretation forcing_notion "2^<ω" "seqle" "0"
  using preorder_on_seqle zero_seqle_max zero_in_seqspace 
  by unfold_locales simp_all

abbreviation SEQle :: "[i, i]  o"  (infixl "≼s" 50)
  where "x ≼s y  Leq(x,y)"

abbreviation SEQIncompatible :: "[i, i]  o"  (infixl "⊥s" 50)
  where "x ⊥s y  Incompatible(x,y)"

lemma seqspace_separative:
  assumes "f2^<ω"
  shows "seq_upd(f,0) ⊥s seq_upd(f,1)" (is "?f ⊥s ?g")
proof 
  assume "compat(?f, ?g)"
  then 
  obtain h where "h  2^<ω" "?f  h" "?g  h"
    by blast
  moreover from f_
  obtain y where "ynat" "f:y2" by blast
  moreover from this
  have "?f: succ(y)  2" "?g: succ(y)  2" 
    using seq_upd_succ_type by blast+
  moreover from this
  have "y,?f`y  ?f" "y,?g`y  ?g" using apply_Pair by auto
  ultimately
  have "y,0  h" "y,1  h" by auto
  moreover from h  2^<ω
  obtain n where "nnat" "h:n2" by blast
  ultimately
  show "False"
    using fun_is_function[of h n "λ_. 2"] 
    unfolding seqspace_def function_def by auto
qed

definition is_seqleR :: "[io,i,i]  o" where
  "is_seqleR(Q,f,g)  g  f"

definition seqleR_fm :: "i  i" where
  "seqleR_fm(fg)  Exists(Exists(And(pair_fm(0,1,fg#+2),subset_fm(1,0))))"

lemma type_seqleR_fm :
  "fg  nat  seqleR_fm(fg)  formula"
  unfolding seqleR_fm_def 
  by simp

lemma arity_seqleR_fm :
  "fg  nat  arity(seqleR_fm(fg)) = succ(fg)"
  unfolding seqleR_fm_def 
  using arity_pair_fm arity_subset_fm nat_simp_union by simp

lemma (in M_basic) seqleR_abs: 
  assumes "M(f)" "M(g)"
  shows "seqleR(f,g)  is_seqleR(M,f,g)"
  unfolding seqleR_def is_seqleR_def 
  using assms apply_abs domain_abs domain_closed[OF M(f)]  domain_closed[OF M(g)]
  by auto

definition
  relP :: "[io,[io,i,i]o,i]  o" where
  "relP(M,r,xy)  (x[M]. y[M]. pair(M,x,y,xy)  r(M,x,y))"

lemma (in M_ctm) seqleR_fm_sats : 
  assumes "fgnat" "envlist(M)" 
  shows "sats(M,seqleR_fm(fg),env)  relP(##M,is_seqleR,nth(fg, env))"
  unfolding seqleR_fm_def is_seqleR_def relP_def
  using assms trans_M sats_subset_fm pair_iff_sats
  by auto


lemma (in M_basic) is_related_abs :
  assumes " f g . M(f)  M(g)  rel(f,g)  is_rel(M,f,g)"
  shows "z . M(z)  relP(M,is_rel,z)  (x y. z = x,y  rel(x,y))"
  unfolding relP_def using pair_in_M_iff assms by auto

definition
  is_RRel :: "[io,[io,i,i]o,i,i]  o" where
  "is_RRel(M,is_r,A,r)  A2[M]. cartprod(M,A,A,A2)  is_Collect(M,A2, relP(M,is_r),r)"

lemma (in M_basic) is_Rrel_abs :
  assumes "M(A)"  "M(r)"
    " f g . M(f)  M(g)  rel(f,g)  is_rel(M,f,g)"
  shows "is_RRel(M,is_rel,A,r)   r = Rrel(rel,A)"
proof -
  from M(A) 
  have "M(z)" if "zA×A" for z
    using cartprod_closed transM[of z "A×A"] that by simp
  then
  have A:"relP(M, is_rel, z)  (x y. z = x, y  rel(x, y))" "M(z)" if "zA×A" for z
    using that is_related_abs[of rel is_rel,OF assms(3)] by auto
  then
  have "Collect(A×A,relP(M,is_rel)) = Collect(A×A,λz. (x y. z = x,y  rel(x,y)))"
    using Collect_cong[of "A×A" "A×A" "relP(M,is_rel)",OF _ A(1)] assms(1) assms(2)
    by auto
  with assms
  show ?thesis unfolding is_RRel_def Rrel_def using cartprod_closed
    by auto
qed

definition
  is_seqlerel :: "[io,i,i]  o" where
  "is_seqlerel(M,A,r)  is_RRel(M,is_seqleR,A,r)"

lemma (in M_basic) seqlerel_abs :
  assumes "M(A)"  "M(r)"
  shows "is_seqlerel(M,A,r)  r = Rrel(seqleR,A)"
  unfolding is_seqlerel_def
  using is_Rrel_abs[OF M(A) M(r),of seqleR is_seqleR] seqleR_abs
  by auto

definition RrelP :: "[iio,i]  i" where
  "RrelP(R,A)  {zA×A. x y. z = x, y  R(x,y)}"
  
lemma Rrel_eq : "RrelP(R,A) = Rrel(R,A)"
  unfolding Rrel_def RrelP_def by auto

context M_ctm
begin

lemma Rrel_closed:
  assumes "AM" 
    " a. a  nat  rel_fm(a)formula"
    " f g . (##M)(f)  (##M)(g)  rel(f,g)  is_rel(##M,f,g)"
    "arity(rel_fm(0)) = 1" 
    " a . a  M  sats(M,rel_fm(0),[a])  relP(##M,is_rel,a)"
  shows "(##M)(Rrel(rel,A))" 
proof -
  have "z M  relP(##M, is_rel, z)  (x y. z = x, y  rel(x, y))" for z
    using assms(3) is_related_abs[of rel is_rel]
    by auto
  with assms
  have "Collect(A×A,λz. (x y. z = x,y  rel(x,y)))  M"
    using Collect_in_M_0p[of "rel_fm(0)" "λ A z . relP(A,is_rel,z)" "λ z.x y. z = x, y  rel(x, y)" ]
        cartprod_closed
    by simp
  then show ?thesis
  unfolding Rrel_def by simp
qed

lemma seqle_in_M: "seqle  M"
  using Rrel_closed seqspace_closed 
    transitivity[OF _ nat_in_M] type_seqleR_fm[of 0] arity_seqleR_fm[of 0]
    seqleR_fm_sats[of 0] seqleR_abs seqlerel_abs 
  unfolding seqle_def seqlerel_def seqleR_def
  by auto

subsection‹Cohen extension is proper›

interpretation ctm_separative "2^<ω" seqle 0
proof (unfold_locales)
  fix f
  let ?q="seq_upd(f,0)" and ?r="seq_upd(f,1)"
  assume "f  2^<ω"
  then
  have "?q ≼s f  ?r ≼s f  ?q ⊥s ?r" 
    using upd_leI seqspace_separative by auto
  moreover from calculation
  have "?q  2^<ω"  "?r  2^<ω"
    using seq_upd_type[of f 2] by auto
  ultimately
  show "q2^<ω. r2^<ω. q ≼s f  r ≼s f  q ⊥s r"
    by (rule_tac bexI)+ ― ‹why the heck auto-tools don't solve this?›
next
  show "2^<ω  M" using nat_into_M seqspace_closed by simp
next
  show "seqle  M" using seqle_in_M .
qed

lemma cohen_extension_is_proper: "G. M_generic(G)  M  GenExt(G)"
  using proper_extension generic_filter_existence zero_in_seqspace
  by force

end (* M_ctm *)

end

Theory Forcing_Main

section‹The main theorem›
theory Forcing_Main
  imports 
  Internal_ZFC_Axioms
  Choice_Axiom
  Ordinals_In_MG
  Succession_Poset

begin

subsection‹The generic extension is countable›
(*
― ‹Useful missing lemma›
lemma surj_imp_well_ord:
  assumes "well_ord(A,r)" "h ∈ surj(A,B)"
  shows "∃s. well_ord(B,r)" 
*)

definition
  minimum :: "i  i  i" where
  "minimum(r,B)  THE b. bB  (yB. y  b  b, y  r)"

lemma well_ord_imp_min:
  assumes 
    "well_ord(A,r)" "B  A" "B  0"
  shows 
    "minimum(r,B)  B" 
proof -
  from ‹well_ord(A,r)
  have "wf[A](r)"
    using well_ord_is_wf[OF ‹well_ord(A,r)] by simp
  with BA
  have "wf[B](r)"
    using Sigma_mono Int_mono wf_subset unfolding wf_on_def by simp
  then
  have " x. x  B  (zB. y. y, z  rB×B  y  B)"
    unfolding wf_on_def using wf_eq_minimal
    by blast
  with B0
  obtain z where
    B: "zB  (y. y,zrB×B  yB)"
    by blast
  then
  have "zB  (yB. y  z  z, y  r)"
  proof -
    {
      fix y
      assume "yB" "yz"
      with ‹well_ord(A,r) B BA
      have "z,yr|y,zr|y=z"
        unfolding well_ord_def tot_ord_def linear_def by auto
      with B yB yz
      have "z,yr"
        by (cases;auto)
    }
    with B
    show ?thesis by blast
  qed
  have "v = z" if "vB  (yB. y  v  v, y  r)" for v
    using that B by auto
  with zB  (yB. y  z  z, y  r)
  show ?thesis
    unfolding minimum_def 
    using the_equality2[OF ex1I[of "λx .xB  (yB. y  x  x, y  r)" z]]
    by auto
qed

lemma well_ord_surj_imp_lepoll:
  assumes "well_ord(A,r)" "h  surj(A,B)"
  shows "B  A"
proof -
  let ?f="λbB. minimum(r, {aA. h`a=b})"
  have "b  B  minimum(r, {a  A . h ` a = b})  {aA. h`a=b}" for b
  proof -
    fix b
    assume "bB"
    with h  surj(A,B)
    have "aA. h`a=b" 
      unfolding surj_def by blast
    then
    have "{aA. h`a=b}  0"
      by auto
    with assms
    show "minimum(r,{aA. h`a=b})  {aA. h`a=b}"
      using well_ord_imp_min by blast
  qed
  moreover from this
  have "?f : B  A"
      using lam_type[of B _ "λ_.A"] by simp
  moreover 
  have "?f ` w = ?f ` x  w = x" if "wB" "xB" for w x
  proof -
    from calculation(1)[OF that(1)] calculation(1)[OF that(2)]
    have "w = h ` minimum(r, {a  A . h ` a = w})"
         "x = h ` minimum(r, {a  A . h ` a = x})"
      by simp_all  
    moreover
    assume "?f ` w = ?f ` x"
    moreover from this and that
    have "minimum(r, {a  A . h ` a = w}) = minimum(r, {a  A . h ` a = x})"
      by simp_all
    moreover from calculation(1,2,4)
    show "w=x" by simp
    qed
  ultimately
  show ?thesis
  unfolding lepoll_def inj_def by blast
qed

lemma (in forcing_data) surj_nat_MG :
  "f. f  surj(nat,M[G])"
proof -
  let ?f="λnnat. val(G,enum`n)"
  have "x  nat  val(G, enum ` x) M[G]" for x
    using GenExtD[THEN iffD2, of _ G] bij_is_fun[OF M_countable] by force
  then
  have "?f: nat  M[G]"
    using lam_type[of nat "λn. val(G,enum`n)" "λ_.M[G]"] by simp
  moreover
  have "nnat. ?f`n = x" if "xM[G]" for x
    using that GenExtD[of _ G] bij_is_surj[OF M_countable] 
    unfolding surj_def by auto
  ultimately
  show ?thesis
    unfolding surj_def by blast
qed

lemma (in G_generic) MG_eqpoll_nat: "M[G]  nat"
proof -
  interpret MG: M_ZF_trans "M[G]"
    using Transset_MG generic pairing_in_MG 
      Union_MG  extensionality_in_MG power_in_MG
      foundation_in_MG  strong_replacement_in_MG[simplified]
      separation_in_MG[simplified] infinity_in_MG
    by unfold_locales simp_all
  obtain f where "f  surj(nat,M[G])"
    using surj_nat_MG by blast
  then
  have "M[G]  nat" 
    using well_ord_surj_imp_lepoll well_ord_Memrel[of nat]
    by simp
  moreover
  have "nat  M[G]"
    using MG.nat_into_M subset_imp_lepoll by auto
  ultimately
  show ?thesis using eqpollI 
    by simp
qed

subsection‹The main result›

theorem extensions_of_ctms:
  assumes 
    "M  nat" "Transset(M)" "M  ZF"
  shows 
    "N. 
      M  N  N  nat  Transset(N)  N  ZF  MN 
      (α. Ord(α)  (α  M  α  N)) 
      (M, [] AC  N  ZFC)"
proof -
  from M  nat›
  obtain enum where "enum  bij(nat,M)"
    using eqpoll_sym unfolding eqpoll_def by blast
  with assms
  interpret M_ctm M enum
    using M_ZF_iff_M_satT
    by intro_locales (simp_all add:M_ctm_axioms_def)
  interpret ctm_separative "2^<ω" seqle 0 M enum
  proof (unfold_locales)
    fix f
    let ?q="seq_upd(f,0)" and ?r="seq_upd(f,1)"
    assume "f  2^<ω"
    then
    have "?q ≼s f  ?r ≼s f  ?q ⊥s ?r" 
      using upd_leI seqspace_separative by auto
    moreover from calculation
    have "?q  2^<ω"  "?r  2^<ω"
      using seq_upd_type[of f 2] by auto
    ultimately
    show "q2^<ω.  r2^<ω. q ≼s f  r ≼s f  q ⊥s r"
      by (rule_tac bexI)+ ― ‹why the heck auto-tools don't solve this?›
  next
    show "2^<ω  M" using nat_into_M seqspace_closed by simp
  next
    show "seqle  M" using seqle_in_M .
  qed
  from cohen_extension_is_proper
  obtain G where "M_generic(G)" 
    "M  GenExt(G)" (is "M?N") 
    by blast
  then 
  interpret G_generic "2^<ω" seqle 0 _ enum G by unfold_locales
  interpret MG: M_ZF "?N"
    using generic pairing_in_MG 
      Union_MG  extensionality_in_MG power_in_MG
      foundation_in_MG  strong_replacement_in_MG[simplified]
      separation_in_MG[simplified] infinity_in_MG
    by unfold_locales simp_all
  have "?N  ZF" 
    using M_ZF_iff_M_satT[of ?N] MG.M_ZF_axioms by simp
  moreover 
  have "M, [] AC  ?N  ZFC"
  proof -
    assume "M, []  AC"
    then
    have "choice_ax(##M)"
      unfolding ZF_choice_fm_def using ZF_choice_auto by simp
    then
    have "choice_ax(##?N)" using choice_in_MG by simp
    with ?N  ZF›
    show "?N  ZFC"
      using ZF_choice_auto sats_ZFC_iff_sats_ZF_AC 
      unfolding ZF_choice_fm_def by simp
  qed
  moreover
  note M  ?N
  moreover
  have "Transset(?N)" using Transset_MG .
  moreover
  have "M  ?N" using M_subset_MG[OF one_in_G] generic by simp
  ultimately
  show ?thesis
    using Ord_MG_iff MG_eqpoll_nat
    by (rule_tac x="?N" in exI, simp)
qed

end